diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index f5d6235..2be7811 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -320,12 +320,15 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m} expectCompatQ one pi -- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁ tres <- inferC ctx sg t + ttags <- expectEnum !ask ctx tres.type -- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type checkTypeC (extendTy zero ret.name tres.type ctx) ret.term Nothing -- if for each "a ⇒ s" in arms, -- Ψ | Γ ⊢ σ · s ⇐ A[a ∷ {ts}/x] ⊳ Σ₂ -- for fixed Σ₂ let arms = SortedMap.toList arms + let armTags = SortedSet.fromList $ map fst arms + unless (ttags == armTags) $ throwError $ BadCaseEnum ttags armTags armres <- for arms $ \(a, s) => checkC ctx sg s (sub1 ret (Tag a :# tres.type)) armout <- allEqual (zip armres arms) diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index 930ab8d..a6ae092 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -20,6 +20,7 @@ data Error q | ExpectedNat (TyContext q d n) (Term q d n) | BadUniverse Universe Universe | TagNotIn TagVal (SortedSet TagVal) +| BadCaseEnum (SortedSet TagVal) (SortedSet TagVal) | BadCaseQtys (TyContext q d n) (List (QOutput q n, Term q d n, Term q d n)) -- first term arg of ClashT is the type @@ -218,6 +219,10 @@ parameters {auto _ : (Eq q, IsQty q, PrettyHL q)} (unicode : Bool) sep [sep ["tag", prettyTag tag, "is not contained in"], termt empty (Enum set)] + BadCaseEnum type arms => + sep ["case expression has head of type", termt empty (Enum type), + "but cases for", termt empty (Enum arms)] + BadCaseQtys ctx arms => hang 4 $ sep $ "inconsistent variable usage in case arms" ::