aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/case
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/case.lux39
-rw-r--r--new-luxc/source/luxc/analyser/case/coverage.lux82
2 files changed, 67 insertions, 54 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index b17dbcbfd..29256865a 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -25,6 +25,7 @@
(exception: #export Cannot-Match-Type-With-Pattern)
(exception: #export Sum-Type-Has-No-Case)
(exception: #export Unrecognized-Pattern-Syntax)
+(exception: #export Cannot-Simplify-Type-For-Pattern-Matching)
(def: (pattern-error type pattern)
(-> Type Code Text)
@@ -51,7 +52,7 @@
[type' (&;with-type-env
(tc;read id))]
(simplify-case-type type'))
- (&;fail (format "Cannot simplify type for pattern-matching: " (%type type)))))
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type))))
(#;Named name unnamedT)
(simplify-case-type unnamedT)
@@ -98,26 +99,26 @@
[outputA (&scope;with-local [name inputT]
next)
idx &scope;next-local]
- (wrap [(#la;BindP idx) outputA])))
+ (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA])))
[cursor (#;Symbol ident)]
(&;with-cursor cursor
(&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident))))
- (^template [<type> <code-tag> <pattern-tag>]
+ (^template [<type> <code-tag>]
[cursor (<code-tag> test)]
(&;with-cursor cursor
(do meta;Monad<Meta>
[_ (&;with-type-env
(tc;check inputT <type>))
outputA next]
- (wrap [(<pattern-tag> test) outputA]))))
- ([Bool #;Bool #la;BoolP]
- [Nat #;Nat #la;NatP]
- [Int #;Int #la;IntP]
- [Deg #;Deg #la;DegP]
- [Frac #;Frac #la;FracP]
- [Text #;Text #la;TextP])
+ (wrap [pattern outputA]))))
+ ([Bool #;Bool]
+ [Nat #;Nat]
+ [Int #;Int]
+ [Deg #;Deg]
+ [Frac #;Frac]
+ [Text #;Text])
(^ [cursor (#;Tuple (list))])
(&;with-cursor cursor
@@ -125,7 +126,7 @@
[_ (&;with-type-env
(tc;check inputT Unit))
outputA next]
- (wrap [(#la;TupleP (list)) outputA])))
+ (wrap [(` ("lux case tuple" [])) outputA])))
(^ [cursor (#;Tuple (list singleton))])
(analyse-pattern #;None inputT singleton next)
@@ -165,7 +166,8 @@
[nextA next]
(wrap [(list) nextA]))
matches)]
- (wrap [(#la;TupleP memberP+) thenA])))
+ (wrap [(` ("lux case tuple" [(~@ memberP+)]))
+ thenA])))
_
(&;fail (pattern-error inputT pattern))
@@ -202,11 +204,11 @@
(type;variant (list;drop (n.dec num-cases) flat-sum))
(` [(~@ values)])
next)]
- (wrap [(#la;VariantP idx num-cases testP)
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
nextA]))
(do meta;Monad<Meta>
[[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)]
- (wrap [(#la;VariantP idx num-cases testP)
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
nextA])))
_
@@ -245,10 +247,9 @@
(function [[patternT bodyT]]
(analyse-pattern #;None inputT patternT (analyse bodyT)))
branchesT)
- _ (case (monad;fold e;Monad<Error>
- &&coverage;merge
- (|> outputH product;left &&coverage;determine)
- (list/map (|>. product;left &&coverage;determine) outputT))
+ outputHC (|> outputH product;left &&coverage;determine)
+ outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT)
+ _ (case (monad;fold e;Monad<Error> &&coverage;merge outputHC outputTC)
(#e;Success coverage)
(if (&&coverage;exhaustive? coverage)
(wrap [])
@@ -256,4 +257,4 @@
(#e;Error error)
(&;fail error))]
- (wrap (#la;Case inputA (#;Cons outputH outputT))))))
+ (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT)))))))))
diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
index cb066a2bf..554aea1a8 100644
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ b/new-luxc/source/luxc/analyser/case/coverage.lux
@@ -1,13 +1,17 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
eq)
- (data [bool "B/" Eq<Bool>]
+ (data [bool "bool/" Eq<Bool>]
[number]
["e" error "error/" Monad<Error>]
- (coll [list "L/" Fold<List>]
- ["D" dict])))
- (luxc (lang ["la" analysis])))
+ text/format
+ (coll [list "list/" Fold<List>]
+ [dict #+ Dict]))
+ [meta "meta/" Monad<Meta>])
+ (luxc ["&" base]
+ (lang ["la" analysis])))
## The coverage of a pattern-matching expression summarizes how well
## all the possible values of an input are being covered by the
@@ -24,7 +28,7 @@
(type: #export #rec Coverage
#Partial
(#Bool Bool)
- (#Variant Nat (D;Dict Nat Coverage))
+ (#Variant Nat (Dict Nat Coverage))
(#Seq Coverage Coverage)
(#Alt Coverage Coverage)
#Exhaustive)
@@ -38,52 +42,60 @@
_
false))
+(exception: #export Unknown-Pattern)
+
(def: #export (determine pattern)
- (-> la;Pattern Coverage)
+ (-> la;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 (#la;BindP _) (^ (#la;TupleP (list))))
- #Exhaustive
+ (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+ (meta/wrap #Exhaustive)
- (^ (#la;TupleP (list singleton)))
+ (^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 (#la;NatP _) (#la;IntP _) (#la;DegP _)
- (#la;FracP _) (#la;TextP _))
- #Partial
+ (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)]
+ [_ (#;Frac _)] [_ (#;Text _)])
+ (meta/wrap #Partial)
## 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.
- (#la;BoolP value)
- (#Bool value)
+ [_ (#;Bool value)]
+ (meta/wrap (#Bool value))
## Tuple patterns can be exhaustive if there is exhaustiveness for all of
## their sub-patterns.
- (#la;TupleP subs)
+ (^code ("lux case tuple" [(~@ subs)]))
(loop [subs subs]
(case subs
#;Nil
- #Exhaustive
+ (meta/wrap #Exhaustive)
(#;Cons sub subs')
- (let [post (recur subs')]
+ (do meta;Monad<Meta>
+ [pre (determine sub)
+ post (recur subs')]
(if (exhaustive? post)
- (determine sub)
- (#Seq (determine sub)
- post)))))
+ (wrap pre)
+ (wrap (#Seq pre post))))))
## Variant patterns can be shown to be exhaustive if all the possible
## cases are handled exhaustively.
- (#la;VariantP tag-id num-tags sub)
- (#Variant num-tags
- (|> (D;new number;Hash<Nat>)
- (D;put tag-id (determine sub))))))
+ (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub)))
+ (do meta;Monad<Meta>
+ [=sub (determine sub)]
+ (wrap (#Variant num-tags
+ (|> (dict;new number;Hash<Nat>)
+ (dict;put tag-id =sub)))))
+
+ _
+ (&;throw Unknown-Pattern (%code pattern))))
(def: (xor left right)
(-> Bool Bool Bool)
@@ -116,11 +128,11 @@
true
[(#Bool sideR) (#Bool sideS)]
- (B/= sideR sideS)
+ (bool/= sideR sideS)
[(#Variant allR casesR) (#Variant allS casesS)]
(and (n.= allR allS)
- (:: (D;Eq<Dict> =) = casesR casesS))
+ (:: (dict;Eq<Dict> =) = casesR casesS))
[(#Seq leftR rightR) (#Seq leftS rightS)]
(and (= leftR leftS)
@@ -166,23 +178,23 @@
(cond (not (n.= allSF allA))
(e;fail "Variants do not match.")
- (:: (D;Eq<Dict> Eq<Coverage>) = casesSF casesA)
+ (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA)
redundant-pattern
## else
(do e;Monad<Error>
[casesM (monad;fold @
(function [[tagA coverageA] casesSF']
- (case (D;get tagA casesSF')
+ (case (dict;get tagA casesSF')
(#;Some coverageSF)
(do @
[coverageM (merge coverageA coverageSF)]
- (wrap (D;put tagA coverageM casesSF')))
+ (wrap (dict;put tagA coverageM casesSF')))
#;None
- (wrap (D;put tagA coverageA casesSF'))))
- casesSF (D;entries casesA))]
- (wrap (if (let [case-coverages (D;values casesM)]
+ (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))
(list;every? exhaustive? case-coverages)))
#Exhaustive
@@ -272,9 +284,9 @@
#;None
(case (list;reverse possibilities)
(#;Cons last prevs)
- (wrap (L/fold (function [left right] (#Alt left right))
- last
- prevs))
+ (wrap (list/fold (function [left right] (#Alt left right))
+ last
+ prevs))
#;Nil
(undefined)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 21:37:58 +0000