rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

check that an enum case head has the right type

Browse source 
haha oops
This commit is contained in:
rhiannon morris 2023-03-26 14:41:17 +02:00
parent 9250789219
commit 78e48911d0
2 changed files with 8 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
lib/Quox/Typechecker.idr
View file

@ -320,12 +320,15 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
expectCompatQ one pi expectCompatQ one pi
-- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁ -- if Ψ | Γ ⊢ σ · t ⇒ {ts} ⊳ Σ₁
tres <- inferC ctx sg t tres <- inferC ctx sg t
ttags <- expectEnum !ask ctx tres.type
-- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type -- if Ψ | Γ, x : {ts} ⊢₀ A ⇐ Type
checkTypeC (extendTy zero ret.name tres.type ctx) ret.term Nothing checkTypeC (extendTy zero ret.name tres.type ctx) ret.term Nothing
-- if for each "a ⇒ s" in arms, -- if for each "a ⇒ s" in arms,
-- Ψ | Γ ⊢ σ · s ⇐ A[a ∷ {ts}/x] ⊳ Σ₂ -- Ψ | Γ ⊢ σ · s ⇐ A[a ∷ {ts}/x] ⊳ Σ₂
-- for fixed Σ₂ -- for fixed Σ₂
let arms = SortedMap.toList arms let arms = SortedMap.toList arms
let armTags = SortedSet.fromList $ map fst arms
unless (ttags == armTags) $ throwError $ BadCaseEnum ttags armTags
armres <- for arms $ \(a, s) => armres <- for arms $ \(a, s) =>
checkC ctx sg s (sub1 ret (Tag a :# tres.type)) checkC ctx sg s (sub1 ret (Tag a :# tres.type))
armout <- allEqual (zip armres arms) armout <- allEqual (zip armres arms)

5
lib/Quox/Typing/Error.idr
View file

@ -20,6 +20,7 @@ data Error q
| ExpectedNat (TyContext q d n) (Term q d n) | ExpectedNat (TyContext q d n) (Term q d n)
| BadUniverse Universe Universe | BadUniverse Universe Universe
| TagNotIn TagVal (SortedSet TagVal) | 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)) | 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 -- 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"], sep [sep ["tag", prettyTag tag, "is not contained in"],
termt empty (Enum set)] 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 => BadCaseQtys ctx arms =>
hang 4 $ sep $ hang 4 $ sep $
"inconsistent variable usage in case arms" :: "inconsistent variable usage in case arms" ::