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

fix the most embarrassing quantity mistake ever

Browse source
This commit is contained in:
rhiannon morris 2023-04-20 19:29:57 +02:00
parent 3f06e8d68b
commit a4ffd74625
2 changed files with 38 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lib/Quox/Typechecker.idr
View file

@ -26,7 +26,7 @@ runTC defs =
export export
popQs : Has ErrorEff fs => QOutput s -> QOutput (s + n) -> Eff fs (QOutput n) popQs : Has ErrorEff fs => QContext s -> QOutput (s + n) -> Eff fs (QOutput n)
popQs [<] qout = pure qout popQs [<] qout = pure qout
popQs (pis :< pi) (qout :< rh) = do expectCompatQ rh pi; popQs pis qout popQs (pis :< pi) (qout :< rh) = do expectCompatQ rh pi; popQs pis qout
@ -363,10 +363,10 @@ mutual
(qty, argty, res) <- expectPi !defs ctx funres.type (qty, argty, res) <- expectPi !defs ctx funres.type
-- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂ -- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ₂
argout <- checkC ctx (subjMult sg qty) arg argty argout <- checkC ctx (subjMult sg qty) arg argty
-- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + Σ₂ -- then Ψ | Γ ⊢ σ · f s ⇒ B[s] ⊳ Σ₁ + πΣ₂
pure $ InfRes { pure $ InfRes {
type = sub1 res $ arg :# argty, type = sub1 res $ arg :# argty,
qout = funres.qout + argout qout = funres.qout + qty * argout
} }
infer' ctx sg (CasePair pi pair ret body) = do infer' ctx sg (CasePair pi pair ret body) = do

35
tests/Tests/Typechecker.idr
View file

@ -78,6 +78,7 @@ defGlobals = fromList
("a'", mkPostulate gany $ FT "A"), ("a'", mkPostulate gany $ FT "A"),
("b", mkPostulate gany $ FT "B"), ("b", mkPostulate gany $ FT "B"),
("f", mkPostulate gany $ Arr One (FT "A") (FT "A")), ("f", mkPostulate gany $ Arr One (FT "A") (FT "A")),
("fω", mkPostulate gany $ Arr Any (FT "A") (FT "A")),
("g", mkPostulate gany $ Arr One (FT "A") (FT "B")), ("g", mkPostulate gany $ Arr One (FT "A") (FT "B")),
("f2", mkPostulate gany $ Arr One (FT "A") $ Arr One (FT "A") (FT "B")), ("f2", mkPostulate gany $ Arr One (FT "A") $ Arr One (FT "A") (FT "B")),
("p", mkPostulate gany $ PiY One "x" (FT "A") $ E $ F "P" :@ BVT 0), ("p", mkPostulate gany $ PiY One "x" (FT "A") $ E $ F "P" :@ BVT 0),
@ -236,6 +237,40 @@ tests = "typechecker" :- [
note "(fail) runtime-relevant type", note "(fail) runtime-relevant type",
testTCFail "1 · A ⇏ ★₀" $ testTCFail "1 · A ⇏ ★₀" $
infer_ empty sone (F "A"), infer_ empty sone (F "A"),
testTC "1 . f ⇒ 1.A → A" $
inferAs empty sone (F "f") (Arr One (FT "A") (FT "A")),
testTC "1 . f ⇐ 1.A → A" $
check_ empty sone (FT "f") (Arr One (FT "A") (FT "A")),
testTCFail "1 . f ⇍ 0.A → A" $
check_ empty sone (FT "f") (Arr Zero (FT "A") (FT "A")),
testTCFail "1 . f ⇍ ω.A → A" $
check_ empty sone (FT "f") (Arr Any (FT "A") (FT "A")),
testTC "1 . (λ x ⇒ f x) ⇐ 1.A → A" $
check_ empty sone
([< "x"] :\\ E (F "f" :@ BVT 0))
(Arr One (FT "A") (FT "A")),
testTC "1 . (λ x ⇒ f x) ⇐ ω.A → A" $
check_ empty sone
([< "x"] :\\ E (F "f" :@ BVT 0))
(Arr Any (FT "A") (FT "A")),
testTCFail "1 . (λ x ⇒ f x) ⇍ 0.A → A" $
check_ empty sone
([< "x"] :\\ E (F "f" :@ BVT 0))
(Arr Zero (FT "A") (FT "A")),
testTC "1 . fω ⇒ ω.A → A" $
inferAs empty sone (F "fω") (Arr Any (FT "A") (FT "A")),
testTC "1 . (λ x ⇒ fω x) ⇐ ω.A → A" $
check_ empty sone
([< "x"] :\\ E (F "fω" :@ BVT 0))
(Arr Any (FT "A") (FT "A")),
testTCFail "1 . (λ x ⇒ fω x) ⇍ 0.A → A" $
check_ empty sone
([< "x"] :\\ E (F "fω" :@ BVT 0))
(Arr Zero (FT "A") (FT "A")),
testTCFail "1 . (λ x ⇒ fω x) ⇍ 1.A → A" $
check_ empty sone
([< "x"] :\\ E (F "fω" :@ BVT 0))
(Arr One (FT "A") (FT "A")),
note "refl : (0·A : ★₀) → (1·x : A) → (x ≡ x : A) ≔ (λ A x ⇒ δ _ ⇒ x)", note "refl : (0·A : ★₀) → (1·x : A) → (x ≡ x : A) ≔ (λ A x ⇒ δ _ ⇒ x)",
testTC "1 · refl ⇒ ⋯" $ inferAs empty sone (F "refl") reflTy, testTC "1 · refl ⇒ ⋯" $ inferAs empty sone (F "refl") reflTy,
testTC "1 · [refl] ⇐ ⋯" $ check_ empty sone (FT "refl") reflTy testTC "1 · [refl] ⇐ ⋯" $ check_ empty sone (FT "refl") reflTy