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. --- stdlib/source/lux/control/exception.lux | 22 +- stdlib/source/lux/data/coll/dictionary/plist.lux | 62 ++++ stdlib/source/lux/lang.lux | 3 + stdlib/source/lux/lang/analysis.lux | 50 +++- stdlib/source/lux/lang/analysis/expression.lux | 125 ++++++++ stdlib/source/lux/lang/analysis/inference.lux | 256 ++++++++++++++++ stdlib/source/lux/lang/analysis/structure.lux | 358 +++++++++++++++++++++++ stdlib/source/lux/lang/module.lux | 239 +++++++++++++++ 8 files changed, 1106 insertions(+), 9 deletions(-) create mode 100644 stdlib/source/lux/data/coll/dictionary/plist.lux create mode 100644 stdlib/source/lux/lang/analysis/expression.lux create mode 100644 stdlib/source/lux/lang/analysis/inference.lux create mode 100644 stdlib/source/lux/lang/analysis/structure.lux create mode 100644 stdlib/source/lux/lang/module.lux (limited to 'stdlib/source') 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] - (coll [list "list/" Functor])) + (coll [list "list/" Functor Fold])) [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]))) + +(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 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 [ ] [(def: @@ -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 [] + [(exception: #export ( {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 + [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 [ ] + ( value) + ( value)) + ([#.Bool primitiveA.bool] + [#.Nat primitiveA.nat] + [#.Int primitiveA.int] + [#.Deg primitiveA.deg] + [#.Frac primitiveA.frac] + [#.Text primitiveA.text]) + + (^template [ ] + (^ (#.Form (list& [_ ( tag)] + values))) + (case values + (#.Cons value #.Nil) + ( analyse tag value) + + _ + ( 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 + ## [procedure (extensionL.find-analysis proc-name)] + ## (procedure analyse eval proc-args)) + + ## (^ (#.Form (list& func args))) + ## (do macro.Monad + ## [[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/stdlib/source/lux/lang/analysis/inference.lux b/stdlib/source/lux/lang/analysis/inference.lux new file mode 100644 index 000000000..732a8e6e3 --- /dev/null +++ b/stdlib/source/lux/lang/analysis/inference.lux @@ -0,0 +1,256 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [list "list/" Functor])) + [macro "macro/" Monad] + [lang] + (lang [type] + (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 [] + [(exception: #export ( {type Type}) + (%type type))] + + [not-a-variant-type] + [not-a-record-type] + [invalid-type-application] + ) + +(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] (typeA.with-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 + [_ (typeA.infer inferT)] + (wrap [inferT (list)])) + + (#.Cons argC args') + (case inferT + (#.Named name unnamedT) + (general analyse unnamedT args) + + (#.UnivQ _) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + output (general analyse + (maybe.assume (type.apply (list varT) inferT)) + args) + bound? (typeA.with-env + (tc.bound? var-id)) + _ (if bound? + (wrap []) + (do @ + [newT new-named-type] + (typeA.with-env + (tc.check varT newT))))] + (wrap output)) + + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) + (general analyse outputT args) + + #.None + (lang.throw invalid-type-application 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 (lang.with-stacked-errors + (function (_ _) + (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 + [?inferT' (typeA.with-env (tc.read infer-id))] + (case ?inferT' + (#.Some inferT') + (general analyse inferT' args) + + _ + (lang.throw cannot-infer [inferT args]))) + + _ + (lang.throw 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 + (lang.throw invalid-type-application inferT)) + + (#.Product _) + (macro/wrap (type.function (type.flatten-tuple inferT) 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) + (-> 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 (inc depth) bodyT)] + (wrap ( env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Sum _) + (let [cases (type.flatten-variant currentT) + actual-size (list.size cases) + boundary (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 dec (n/* +2)) inferT)] + (type.function (list (replace! caseT)) + (replace! currentT))))) + + #.None + (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])) + + (n/< expected-size 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 dec (n/* +2)) inferT)] + (type.function (list (replace! caseT)) + (replace! currentT)))))) + + ## else + (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (variant tag expected-size outputT) + + #.None + (lang.throw invalid-type-application 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] + (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 [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 + [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 [ ] + ( _) + (do @ + [[instance-id instanceT] (typeA.with-env )] + (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 + [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 + [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 [ ] + ( _) + (do @ + [[instance-id instanceT] (typeA.with-env )] + (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 + [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 + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do macro.Monad + [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 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 []) + (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 (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)) + 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 + [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/format + ["e" error] + (coll [list "list/" Fold Functor] + (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 [] + [(exception: #export ( {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 + [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 + [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 + [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 + [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 + [_ (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) (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 module)) + compiler) + []]) + ((//.throw can-only-change-state-of-active-module [module-name ]) + compiler))) + + #.None + ((//.throw unknown-module module-name) compiler)))) + + (def: #export ( 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) + true + _ false)]) + + #.None + ((//.throw unknown-module module-name) compiler))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(do-template [ ] + [(def: ( module-name) + (-> Text (Meta )) + (function (_ compiler) + (case (|> compiler (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#e.Success [compiler (get@ 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 + [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 + [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))))) -- cgit v1.2.3