From 8ba6ac8952e3457b1a09e30ac5312168d48006d1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 May 2018 00:11:49 -0400 Subject: - Migrated structure analysis to stdlib. - Added an easy way to report information in exceptions. --- new-luxc/source/luxc/lang.lux | 47 --- new-luxc/source/luxc/lang/analysis.lux | 111 ------- new-luxc/source/luxc/lang/analysis/common.lux | 21 -- new-luxc/source/luxc/lang/analysis/expression.lux | 126 -------- new-luxc/source/luxc/lang/analysis/inference.lux | 252 --------------- new-luxc/source/luxc/lang/analysis/structure.lux | 365 ---------------------- new-luxc/source/luxc/lang/module.lux | 234 -------------- 7 files changed, 1156 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/analysis.lux delete mode 100644 new-luxc/source/luxc/lang/analysis/common.lux delete mode 100644 new-luxc/source/luxc/lang/analysis/expression.lux delete mode 100644 new-luxc/source/luxc/lang/analysis/inference.lux delete mode 100644 new-luxc/source/luxc/lang/analysis/structure.lux delete mode 100644 new-luxc/source/luxc/lang/module.lux (limited to 'new-luxc/source/luxc') 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])) - (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 [ ] - [(def: ( inner) - (-> Analysis Analysis) - (` ( (~ 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 [] - [(exception: #export ( {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 - [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 [ ] - ( value) - ( 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 - [procedure (extensionL.find-analysis proc-name)] - (procedure analyse eval proc-args)) - - (^template [ ] - (^ (#.Form (list& [_ ( tag)] - values))) - (case values - (#.Cons value #.Nil) - ( analyse tag value) - - _ - ( 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 - [[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/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux deleted file mode 100644 index 9bc668050..000000000 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ /dev/null @@ -1,252 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Functor])) - [macro "macro/" Monad] - (lang [type] - (type ["tc" check]))) - (luxc ["&" lang] - (lang ["la" analysis #+ Analysis] - (analysis ["&." common])))) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [Cannot-Infer] - [Cannot-Infer-Argument] - [Smaller-Variant-Than-Expected] - [Invalid-Type-Application] - [Not-A-Record-Type] - [Not-A-Variant-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 "")))) - -(def: (replace-bound bound-idx replacementT type) - (-> Nat Type Type Type) - (case type - (#.Primitive name params) - (#.Primitive name (list/map (replace-bound bound-idx replacementT) params)) - - (^template [] - ( left right) - ( (replace-bound bound-idx replacementT left) - (replace-bound bound-idx replacementT right))) - ([#.Sum] - [#.Product] - [#.Function] - [#.Apply]) - - (#.Bound idx) - (if (n/= bound-idx idx) - replacementT - type) - - (^template [] - ( env quantified) - ( (list/map (replace-bound bound-idx replacementT) env) - (replace-bound (n/+ +2 bound-idx) replacementT quantified))) - ([#.UnivQ] - [#.ExQ]) - - _ - type)) - -(def: new-named-type - (Meta Type) - (do macro.Monad - [[_module _line _column] macro.cursor - [ex-id exT] (&.with-type-env tc.existential)] - (wrap (#.Primitive (format "{New Type @ " (%t _module) - "," (%n _line) - "," (%n _column) - "} " (%n ex-id)) - (list))))) - -## Type-inference works by applying some (potentially quantified) type -## to a sequence of values. -## Function types are used for this, although inference is not always -## done for function application (alternative uses may be records and -## tagged variants). -## 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)])) - (case args - #.Nil - (do macro.Monad - [_ (&.infer inferT)] - (wrap [inferT (list)])) - - (#.Cons argC args') - (case inferT - (#.Named name unnamedT) - (general analyse unnamedT args) - - (#.UnivQ _) - (do macro.Monad - [[var-id varT] (&.with-type-env tc.var)] - (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) - - (#.ExQ _) - (do macro.Monad - [[var-id varT] (&.with-type-env tc.var) - output (general analyse - (maybe.assume (type.apply (list varT) inferT)) - args) - bound? (&.with-type-env - (tc.bound? var-id)) - _ (if bound? - (wrap []) - (do @ - [newT new-named-type] - (&.with-type-env - (tc.check varT newT))))] - (wrap output)) - - (#.Apply inputT transT) - (case (type.apply (list inputT) transT) - (#.Some outputT) - (general analyse outputT args) - - #.None - (&.throw Invalid-Type-Application (%type inferT))) - - ## Arguments are inferred back-to-front because, by convention, - ## Lux functions take the most important arguments *last*, which - ## means that the most information for doing proper inference is - ## located in the last arguments to a function call. - ## By inferring back-to-front, a lot of type-annotations can be - ## avoided in Lux code, since the inference algorithm can piece - ## things together more easily. - (#.Function inputT outputT) - (do macro.Monad - [[outputT' args'A] (general analyse outputT args') - argA (&.with-stacked-errors - (function (_ _) - (ex.construct Cannot-Infer-Argument - (format "Inferred Type: " (%type inputT) "\n" - " Argument: " (%code argC)))) - (&.with-type inputT - (analyse argC)))] - (wrap [outputT' (list& argA args'A)])) - - (#.Var infer-id) - (do macro.Monad - [?inferT' (&.with-type-env (tc.read infer-id))] - (case ?inferT' - (#.Some inferT') - (general analyse inferT' args) - - _ - (&.throw Cannot-Infer (cannot-infer inferT args)))) - - _ - (&.throw Cannot-Infer (cannot-infer inferT args))) - )) - -## Turns a record type into the kind of function type suitable for inference. -(def: #export (record inferT) - (-> Type (Meta Type)) - (case inferT - (#.Named name unnamedT) - (record unnamedT) - - (^template [] - ( env bodyT) - (do macro.Monad - [bodyT+ (record bodyT)] - (wrap ( env bodyT+)))) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (record outputT) - - #.None - (&.throw Invalid-Type-Application (%type inferT))) - - (#.Product _) - (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) - - _ - (&.throw Not-A-Record-Type (%type inferT)))) - -## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected-size inferT) - (-> Nat Nat Type (Meta Type)) - (loop [depth +0 - currentT inferT] - (case currentT - (#.Named name unnamedT) - (do macro.Monad - [unnamedT+ (recur depth unnamedT)] - (wrap unnamedT+)) - - (^template [] - ( env bodyT) - (do macro.Monad - [bodyT+ (recur (n/inc depth) bodyT)] - (wrap ( env bodyT+)))) - ([#.UnivQ] - [#.ExQ]) - - (#.Sum _) - (let [cases (type.flatten-variant currentT) - actual-size (list.size cases) - boundary (n/dec expected-size)] - (cond (or (n/= expected-size actual-size) - (and (n/> expected-size actual-size) - (n/< boundary tag))) - (case (list.nth tag cases) - (#.Some caseT) - (macro/wrap (if (n/= +0 depth) - (type.function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] - (type.function (list (replace! caseT)) - (replace! currentT))))) - - #.None - (&common.variant-out-of-bounds-error inferT expected-size tag)) - - (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)))) - - (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)] - (type.function (list (replace! caseT)) - (replace! currentT)))))) - - ## else - (&common.variant-out-of-bounds-error inferT expected-size tag))) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (variant tag expected-size outputT) - - #.None - (&.throw Invalid-Type-Application (%type inferT))) - - _ - (&.throw Not-A-Variant-Type (%type inferT))))) 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] - (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 [] - [(exception: #export ( {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 - [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 [ ] - ( _) - (do @ - [[instance-id instanceT] (&.with-type-env )] - (&.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 - [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 - [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 [ ] - ( _) - (do @ - [[instance-id instanceT] (&.with-type-env )] - (&.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 - [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 - (function (_ [key val]) - (case key - [_ (#.Tag key)] - (do macro.Monad - [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 wrap [(list) Top]) - - (#.Cons [head-k head-v] _) - (do macro.Monad - [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 (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)) - 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 - [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/format - ["e" error] - (coll [list "list/" Fold Functor])) - [macro] - (macro [code])) - (luxc ["&" lang] - (lang ["&." scope]))) - -(do-template [] - [(exception: #export ( {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 - [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 - [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 - [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 - [_ (create hash name) - output (&.with-current-module name - action) - module (macro.find-module name)] - (wrap [module output]))) - -(do-template [ ] - [(def: #export ( 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 module)) - compiler) - []]) - ((&.throw Can-Only-Change-State-Of-Active-Module - (format " Module: " module-name "\n" - "Desired state: " )) - compiler))) - - #.None - ((&.throw Unknown-Module module-name) compiler)))) - (def: #export ( 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) - 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 [ ] - [(def: ( module-name) - (-> Text (Meta )) - (function (_ compiler) - (case (|> compiler (get@ #.modules) (&.pl-get module-name)) - (#.Some module) - (#e.Success [compiler (get@ 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 - [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 - [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))))) -- cgit v1.2.3