aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/lang/analysis/case.lux (renamed from new-luxc/source/luxc/lang/analysis/case.lux)225
-rw-r--r--stdlib/source/lux/lang/analysis/case/coverage.lux (renamed from new-luxc/source/luxc/lang/analysis/case/coverage.lux)120
2 files changed, 175 insertions, 170 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/stdlib/source/lux/lang/analysis/case.lux
index d9efa2bf4..3140a9d7e 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/stdlib/source/lux/lang/analysis/case.lux
@@ -1,8 +1,8 @@
(.module:
- lux
+ [lux #- case]
(lux (control [monad #+ do]
["ex" exception #+ exception:]
- eq)
+ [equality #+ Eq])
(data [bool]
[number]
[product]
@@ -11,38 +11,43 @@
[text]
text/format
(coll [list "list/" Fold<List> Monoid<List> Functor<List>]))
+ [function]
[macro]
(macro [code])
+ [lang]
(lang [type]
- (type ["tc" check])))
- (luxc ["&" lang]
- (lang ["&." scope]
- ["la" analysis]
- (analysis [".A" common]
- [".A" structure]
- (case [".A" coverage])))))
+ (type ["tc" check])
+ [".L" scope]
+ [".L" analysis #+ Pattern Analysis Analyser]
+ (analysis [".A" type]
+ [".A" structure]
+ (case [".A" coverage])))))
+
+(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code})
+ (ex.report ["Type" (%type type)]
+ ["Pattern" (%code pattern)]))
+
+(exception: #export (sum-type-has-no-case {case Nat} {type Type})
+ (ex.report ["Case" (%n case)]
+ ["Type" (%type type)]))
+
+(exception: #export (unrecognized-pattern-syntax {pattern Code})
+ (%code pattern))
+
+(exception: #export (cannot-simplify-type-for-pattern-matching {type Type})
+ (%type type))
(do-template [<name>]
[(exception: #export (<name> {message Text})
message)]
- [Cannot-Match-Type-With-Pattern]
- [Sum-Type-Has-No-Case]
- [Unrecognized-Pattern-Syntax]
- [Cannot-Simplify-Type-For-Pattern-Matching]
- [Cannot-Have-Empty-Branches]
- [Non-Exhaustive-Pattern-Matching]
- [Symbols-Must-Be-Unqualified-Inside-Patterns]
+ [cannot-have-empty-branches]
+ [non-exhaustive-pattern-matching]
)
-(def: (pattern-error type pattern)
- (-> Type Code Text)
- (format " Type: " (%type type) "\n"
- "Pattern: " (%code pattern)))
-
(def: (re-quantify envs baseT)
(-> (List (List Type)) Type Type)
- (case envs
+ (.case envs
#.Nil
baseT
@@ -61,17 +66,17 @@
(loop [envs (: (List (List Type))
(list))
caseT caseT]
- (case caseT
+ (.case caseT
(#.Var id)
(do macro.Monad<Meta>
- [?caseT' (&.with-type-env
+ [?caseT' (typeA.with-env
(tc.read id))]
- (case ?caseT'
+ (.case ?caseT'
(#.Some caseT')
(recur envs caseT')
_
- (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+ (lang.throw cannot-simplify-type-for-pattern-matching caseT)))
(#.Named name unnamedT)
(recur envs unnamedT)
@@ -79,43 +84,34 @@
(#.UnivQ env unquantifiedT)
(recur (#.Cons env envs) unquantifiedT)
- ## (^template [<tag> <instancer>]
- ## (<tag> _)
- ## (do macro.Monad<Meta>
- ## [[_ instanceT] (&.with-type-env
- ## <instancer>)]
- ## (recur (maybe.assume (type.apply (list instanceT) caseT)))))
- ## ([#.UnivQ tc.var]
- ## [#.ExQ tc.existential])
-
(#.ExQ _)
(do macro.Monad<Meta>
- [[ex-id exT] (&.with-type-env
+ [[ex-id exT] (typeA.with-env
tc.existential)]
(recur envs (maybe.assume (type.apply (list exT) caseT))))
(#.Apply inputT funcT)
- (case funcT
+ (.case funcT
(#.Var funcT-id)
(do macro.Monad<Meta>
- [funcT' (&.with-type-env
+ [funcT' (typeA.with-env
(do tc.Monad<Check>
[?funct' (tc.read funcT-id)]
- (case ?funct'
+ (.case ?funct'
(#.Some funct')
(wrap funct')
_
- (tc.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
+ (tc.throw cannot-simplify-type-for-pattern-matching caseT))))]
(recur envs (#.Apply inputT funcT')))
_
- (case (type.apply (list inputT) funcT)
+ (.case (type.apply (list inputT) funcT)
(#.Some outputT)
(recur envs outputT)
#.None
- (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+ (lang.throw cannot-simplify-type-for-pattern-matching caseT)))
(#.Product _)
(|> caseT
@@ -127,6 +123,15 @@
_
(:: macro.Monad<Meta> wrap (re-quantify envs caseT)))))
+(def: (analyse-primitive type inputT cursor output next)
+ (All [a] (-> Type Type Cursor Pattern (Meta a) (Meta [Pattern a])))
+ (lang.with-cursor cursor
+ (do macro.Monad<Meta>
+ [_ (typeA.with-env
+ (tc.check inputT type))
+ outputA next]
+ (wrap [output outputA]))))
+
## This function handles several concerns at once, but it must be that
## way because those concerns are interleaved when doing
## pattern-matching and they cannot be separated.
@@ -144,74 +149,57 @@
## That is why the body must be analysed in the context of the
## pattern, and not separately.
(def: (analyse-pattern num-tags inputT pattern next)
- (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a])))
- (case pattern
+ (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a])))
+ (.case pattern
[cursor (#.Symbol ["" name])]
- (&.with-cursor cursor
+ (lang.with-cursor cursor
(do macro.Monad<Meta>
- [outputA (&scope.with-local [name inputT]
+ [outputA (scopeL.with-local [name inputT]
next)
- idx &scope.next-local]
- (wrap [(` ("lux case bind" (~ (code.nat idx)))) outputA])))
-
- [cursor (#.Symbol ident)]
- (&.with-cursor cursor
- (&.throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident)))
-
- (^template [<type> <code-tag>]
- [cursor (<code-tag> test)]
- (&.with-cursor cursor
- (do macro.Monad<Meta>
- [_ (&.with-type-env
- (tc.check inputT <type>))
- outputA next]
- (wrap [pattern outputA]))))
- ([Bool #.Bool]
- [Nat #.Nat]
- [Int #.Int]
- [Deg #.Deg]
- [Frac #.Frac]
- [Text #.Text])
-
- (^ [cursor (#.Tuple (list))])
- (&.with-cursor cursor
- (do macro.Monad<Meta>
- [_ (&.with-type-env
- (tc.check inputT Top))
- outputA next]
- (wrap [(` ("lux case tuple" [])) outputA])))
-
+ idx scopeL.next-local]
+ (wrap [(#analysisL.Bind idx) outputA])))
+
+ (^template [<type> <input> <output>]
+ [cursor <input>]
+ (analyse-primitive <type> inputT cursor (#analysisL.Simple <output>) next))
+ ([Bool (#.Bool pattern-value) (#analysisL.Bool pattern-value)]
+ [Nat (#.Nat pattern-value) (#analysisL.Nat pattern-value)]
+ [Int (#.Int pattern-value) (#analysisL.Int pattern-value)]
+ [Deg (#.Deg pattern-value) (#analysisL.Deg pattern-value)]
+ [Frac (#.Frac pattern-value) (#analysisL.Frac pattern-value)]
+ [Text (#.Text pattern-value) (#analysisL.Text pattern-value)]
+ [Top (#.Tuple #.Nil) #analysisL.Unit])
+
(^ [cursor (#.Tuple (list singleton))])
(analyse-pattern #.None inputT singleton next)
[cursor (#.Tuple sub-patterns)]
- (&.with-cursor cursor
+ (lang.with-cursor cursor
(do macro.Monad<Meta>
[inputT' (simplify-case-type inputT)]
- (case inputT'
+ (.case inputT'
(#.Product _)
(let [sub-types (type.flatten-tuple inputT')
num-sub-types (maybe.default (list.size sub-types)
num-tags)
num-sub-patterns (list.size sub-patterns)
matches (cond (n/< num-sub-types num-sub-patterns)
- (let [[prefix suffix] (list.split (n/dec num-sub-patterns) sub-types)]
+ (let [[prefix suffix] (list.split (dec num-sub-patterns) sub-types)]
(list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns))
(n/> num-sub-types num-sub-patterns)
- (let [[prefix suffix] (list.split (n/dec num-sub-types) sub-patterns)]
+ (let [[prefix suffix] (list.split (dec num-sub-types) sub-patterns)]
(list.zip2 sub-types (list/compose prefix (list (code.tuple suffix)))))
## (n/= num-sub-types num-sub-patterns)
- (list.zip2 sub-types sub-patterns)
- )]
+ (list.zip2 sub-types sub-patterns))]
(do @
[[memberP+ thenA] (list/fold (: (All [a]
- (-> [Type Code] (Meta [(List la.Pattern) a])
- (Meta [(List la.Pattern) a])))
+ (-> [Type Code] (Meta [(List Pattern) a])
+ (Meta [(List Pattern) a])))
(function (_ [memberT memberC] then)
(do @
- [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a])))
+ [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a])))
analyse-pattern)
#.None memberT memberC then)]
(wrap [(list& memberP memberP+) thenA]))))
@@ -219,81 +207,76 @@
[nextA next]
(wrap [(list) nextA]))
(list.reverse matches))]
- (wrap [(` ("lux case tuple" [(~+ memberP+)]))
+ (wrap [(analysisL.product-pattern memberP+)
thenA])))
_
- (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))
+ (lang.throw cannot-match-type-with-pattern [inputT pattern])
)))
[cursor (#.Record record)]
(do macro.Monad<Meta>
[record (structureA.normalize record)
[members recordT] (structureA.order record)
- _ (&.with-type-env
+ _ (typeA.with-env
(tc.check inputT recordT))]
(analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next))
[cursor (#.Tag tag)]
- (&.with-cursor cursor
+ (lang.with-cursor cursor
(analyse-pattern #.None inputT (` ((~ pattern))) next))
(^ [cursor (#.Form (list& [_ (#.Nat idx)] values))])
- (&.with-cursor cursor
+ (lang.with-cursor cursor
(do macro.Monad<Meta>
[inputT' (simplify-case-type inputT)]
- (case inputT'
+ (.case inputT'
(#.Sum _)
(let [flat-sum (type.flatten-variant inputT')
size-sum (list.size flat-sum)
num-cases (maybe.default size-sum num-tags)]
- (case (list.nth idx flat-sum)
+ (.case (list.nth idx flat-sum)
(^multi (#.Some case-type)
(n/< num-cases idx))
- (if (and (n/> num-cases size-sum)
- (n/= (n/dec num-cases) idx))
- (do macro.Monad<Meta>
- [[testP nextA] (analyse-pattern #.None
- (type.variant (list.drop (n/dec num-cases) flat-sum))
+ (do macro.Monad<Meta>
+ [[testP nextA] (if (and (n/> num-cases size-sum)
+ (n/= (dec num-cases) idx))
+ (analyse-pattern #.None
+ (type.variant (list.drop (dec num-cases) flat-sum))
(` [(~+ values)])
- next)]
- (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP)))
- nextA]))
- (do macro.Monad<Meta>
- [[testP nextA] (analyse-pattern #.None case-type (` [(~+ values)]) next)]
- (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP)))
- nextA])))
+ next)
+ (analyse-pattern #.None case-type (` [(~+ values)]) next))]
+ (wrap [(analysisL.sum-pattern num-cases idx testP)
+ nextA]))
_
- (&.throw Sum-Type-Has-No-Case
- (format "Case: " (%n idx) "\n"
- "Type: " (%type inputT)))))
+ (lang.throw sum-type-has-no-case [idx inputT])))
_
- (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)))))
+ (lang.throw cannot-match-type-with-pattern [inputT pattern]))))
(^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
- (&.with-cursor cursor
+ (lang.with-cursor cursor
(do macro.Monad<Meta>
[tag (macro.normalize tag)
[idx group variantT] (macro.resolve-tag tag)
- _ (&.with-type-env
+ _ (typeA.with-env
(tc.check inputT variantT))]
(analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
_
- (&.throw Unrecognized-Pattern-Syntax (%code pattern))
+ (lang.throw unrecognized-pattern-syntax pattern)
))
-(def: #export (analyse-case analyse inputC branches)
- (-> &.Analyser Code (List [Code Code]) (Meta la.Analysis))
- (case branches
+(def: #export (case analyse inputC branches)
+ (-> Analyser Code (List [Code Code]) (Meta Analysis))
+ (.case branches
#.Nil
- (&.throw Cannot-Have-Empty-Branches "")
+ (lang.throw cannot-have-empty-branches "")
(#.Cons [patternH bodyH] branchesT)
(do macro.Monad<Meta>
- [[inputT inputA] (commonA.with-unknown-type
+ [[inputT inputA] (typeA.with-inference
(analyse inputC))
outputH (analyse-pattern #.None inputT patternH (analyse bodyH))
outputT (monad.map @
@@ -302,11 +285,11 @@
branchesT)
outputHC (|> outputH product.left coverageA.determine)
outputTC (monad.map @ (|>> product.left coverageA.determine) outputT)
- _ (case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC)
+ _ (.case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC)
(#e.Success coverage)
- (&.assert Non-Exhaustive-Pattern-Matching ""
- (coverageA.exhaustive? coverage))
+ (lang.assert non-exhaustive-pattern-matching ""
+ (coverageA.exhaustive? coverage))
(#e.Error error)
- (&.fail error))]
- (wrap (` ("lux case" (~ inputA) (~ (code.record (list& outputH outputT)))))))))
+ (lang.fail error))]
+ (wrap (#analysisL.Case inputA [outputH outputT])))))
diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/analysis/case/coverage.lux
index 38f977011..da256206f 100644
--- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux
+++ b/stdlib/source/lux/lang/analysis/case/coverage.lux
@@ -2,19 +2,41 @@
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:]
- eq)
+ equality)
(data [bool "bool/" Eq<Bool>]
[number]
["e" error "error/" Monad<Error>]
+ [maybe]
text/format
(coll [list "list/" Fold<List>]
(dictionary ["dict" unordered #+ Dict])))
- [macro "macro/" Monad<Meta>])
- (luxc ["&" lang]
- (lang ["la" analysis])))
-
-(exception: #export (Unknown-Pattern {message Text})
- message)
+ [macro "macro/" Monad<Meta>]
+ [lang]
+ (lang [".L" analysis #+ Pattern Variant])))
+
+(def: cases
+ (-> (Maybe Nat) Nat)
+ (|>> (maybe.default +0)))
+
+(def: (variant sum-side)
+ (-> (Either Pattern Pattern) (Variant Pattern))
+ (loop [lefts +0
+ variantP sum-side]
+ (case variantP
+ (#.Left valueP)
+ (case valueP
+ (#analysisL.Complex (#analysisL.Sum value-side))
+ (recur (inc lefts) value-side)
+
+ _
+ {#analysisL.lefts lefts
+ #analysisL.right? false
+ #analysisL.value valueP})
+
+ (#.Right valueP)
+ {#analysisL.lefts lefts
+ #analysisL.right? true
+ #analysisL.value valueP})))
## The coverage of a pattern-matching expression summarizes how well
## all the possible values of an input are being covered by the
@@ -31,7 +53,7 @@
(type: #export #rec Coverage
#Partial
(#Bool Bool)
- (#Variant Nat (Dict Nat Coverage))
+ (#Variant (Maybe Nat) (Dict Nat Coverage))
(#Seq Coverage Coverage)
(#Alt Coverage Coverage)
#Exhaustive)
@@ -46,57 +68,56 @@
false))
(def: #export (determine pattern)
- (-> la.Pattern (Meta Coverage))
+ (-> Pattern (Meta Coverage))
(case pattern
- ## Binding amounts to exhaustive coverage because any value can be
- ## matched that way.
- ## Unit [] amounts to exhaustive coverage because there is only one
- ## possible value, so matching against it covers all cases.
- (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+ (^or (#analysisL.Simple #analysisL.Unit)
+ (#analysisL.Bind _))
(macro/wrap #Exhaustive)
- (^code ("lux case tuple" [(~ singleton)]))
- (determine singleton)
-
## Primitive patterns always have partial coverage because there
## are too many possibilities as far as values go.
- (^or [_ (#.Nat _)] [_ (#.Int _)] [_ (#.Deg _)]
- [_ (#.Frac _)] [_ (#.Text _)])
- (macro/wrap #Partial)
+ (^template [<tag>]
+ (#analysisL.Simple (<tag> _))
+ (macro/wrap #Partial))
+ ([#analysisL.Nat]
+ [#analysisL.Int]
+ [#analysisL.Deg]
+ [#analysisL.Frac]
+ [#analysisL.Text])
## Bools are the exception, since there is only "true" and
## "false", which means it is possible for boolean
## pattern-matching to become exhaustive if complementary parts meet.
- [_ (#.Bool value)]
+ (#analysisL.Simple (#analysisL.Bool value))
(macro/wrap (#Bool value))
## Tuple patterns can be exhaustive if there is exhaustiveness for all of
## their sub-patterns.
- (^code ("lux case tuple" [(~+ subs)]))
- (loop [subs subs]
- (case subs
- #.Nil
- (macro/wrap #Exhaustive)
-
- (#.Cons sub subs')
- (do macro.Monad<Meta>
- [pre (determine sub)
- post (recur subs')]
- (if (exhaustive? post)
- (wrap pre)
- (wrap (#Seq pre post))))))
-
- ## Variant patterns can be shown to be exhaustive if all the possible
- ## cases are handled exhaustively.
- (^code ("lux case variant" (~ [_ (#.Nat tag-id)]) (~ [_ (#.Nat num-tags)]) (~ sub)))
+ (#analysisL.Complex (#analysisL.Product [left right]))
(do macro.Monad<Meta>
- [=sub (determine sub)]
- (wrap (#Variant num-tags
- (|> (dict.new number.Hash<Nat>)
- (dict.put tag-id =sub)))))
-
- _
- (&.throw Unknown-Pattern (%code pattern))))
+ [left (determine left)
+ right (determine right)]
+ (case right
+ (#Exhaustive _)
+ (wrap left)
+
+ _
+ (wrap (#Seq left right))))
+
+ (#analysisL.Complex (#analysisL.Sum sum-side))
+ (let [[variant-lefts variant-right? variant-value] (variant sum-side)]
+ ## Variant patterns can be shown to be exhaustive if all the possible
+ ## cases are handled exhaustively.
+ (do macro.Monad<Meta>
+ [value-coverage (determine variant-value)
+ #let [variant-idx (if variant-right?
+ (inc variant-lefts)
+ variant-lefts)]]
+ (wrap (#Variant (if variant-right?
+ (#.Some variant-idx)
+ #.None)
+ (|> (dict.new number.Hash<Nat>)
+ (dict.put variant-idx value-coverage))))))))
(def: (xor left right)
(-> Bool Bool Bool)
@@ -132,9 +153,10 @@
(bool/= sideR sideS)
[(#Variant allR casesR) (#Variant allS casesS)]
- (and (n/= allR allS)
+ (and (n/= (cases allR)
+ (cases allS))
(:: (dict.Eq<Dict> =) = casesR casesS))
-
+
[(#Seq leftR rightR) (#Seq leftS rightS)]
(and (= leftR leftS)
(= rightR rightS))
@@ -176,7 +198,7 @@
(error/wrap #Exhaustive)
[(#Variant allA casesA) (#Variant allSF casesSF)]
- (cond (not (n/= allSF allA))
+ (cond (not (n/= (cases allSF) (cases allA)))
(e.fail "Variants do not match.")
(:: (dict.Eq<Dict> Eq<Coverage>) = casesSF casesA)
@@ -196,7 +218,7 @@
(wrap (dict.put tagA coverageA casesSF'))))
casesSF (dict.entries casesA))]
(wrap (if (let [case-coverages (dict.values casesM)]
- (and (n/= allSF (list.size case-coverages))
+ (and (n/= (cases allSF) (list.size case-coverages))
(list.every? exhaustive? case-coverages)))
#Exhaustive
(#Variant allSF casesM)))))