rhi/quox
rhi
/
quox
1
0
Fork 0
Code Issues 14 Pull Requests Releases Wiki Activity

qty lub is total actually (usually ω)

This commit is contained in:
rhiannon morris 2023-05-12 17:28:29 +02:00
parent ba755a9c4b
commit f6abf084b3
2 changed files with 12 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
lib/Quox/Syntax/Qty.idr
View File

@ -83,10 +83,11 @@ compat pi rh = pi == rh
||| "π ∨ ρ" ||| "π ∨ ρ"
||| |||
||| returns some quantity τ where π ≤ τ and ρ ≤ τ, if one exists. ||| returns a quantity τ with π ≤ τ and ρ ≤ τ.
||| if π = ρ, then it's that, otherwise it's ω.
public export public export
lub : Qty -> Qty -> Maybe Qty lub : Qty -> Qty -> Qty
lub p q = Just $ if p == q then p else Any lub p q = if p == q then p else Any
||| to maintain subject reduction, only 0 or 1 can occur ||| to maintain subject reduction, only 0 or 1 can occur

23
lib/Quox/Typechecker.idr
View File

@ -39,15 +39,15 @@ parameters (loc : Loc)
popQ pi = popQs [< pi] popQ pi = popQs [< pi]
export export
lubs1 : List1 (QOutput n) -> Maybe (QOutput n) lubs1 : List1 (QOutput n) -> QOutput n
lubs1 ([<] ::: _) = Just [<] lubs1 ([<] ::: _) = [<]
lubs1 ((qs :< p) ::: pqs) = lubs1 ((qs :< p) ::: pqs) =
let (qss, ps) = unzip $ map unsnoc pqs in let (qss, ps) = unzip $ map unsnoc pqs in
[|lubs1 (qs ::: qss) :< foldlM lub p ps|] lubs1 (qs ::: qss) :< foldl lub p ps
export export
lubs : TyContext d n -> List (QOutput n) -> Maybe (QOutput n) lubs : TyContext d n -> List (QOutput n) -> QOutput n
lubs ctx [] = Just $ zeroFor ctx lubs ctx [] = zeroFor ctx
lubs ctx (x :: xs) = lubs1 $ x ::: xs lubs ctx (x :: xs) = lubs1 $ x ::: xs
@ -397,12 +397,9 @@ mutual
unless (ttags == armTags) $ throw $ BadCaseEnum loc ttags armTags unless (ttags == armTags) $ throw $ BadCaseEnum loc ttags armTags
armres <- for arms $ \(a, s) => armres <- for arms $ \(a, s) =>
checkC ctx sg s $ sub1 ret $ Ann (Tag a s.loc) tres.type s.loc checkC ctx sg s $ sub1 ret $ Ann (Tag a s.loc) tres.type s.loc
let Just armout = lubs ctx armres
| _ => throw $ BadQtys loc "case arms" ctx $
zipWith (\qs, (t, rhs) => (qs, Tag t noLoc)) armres arms
pure $ InfRes { pure $ InfRes {
type = sub1 ret t, type = sub1 ret t,
qout = pi * tres.qout + armout qout = pi * tres.qout + lubs ctx armres
} }
infer' ctx sg (CaseNat pi pi' n ret zer suc loc) = do infer' ctx sg (CaseNat pi pi' n ret zer suc loc) = do
@ -474,12 +471,8 @@ mutual
val1 = val1.term val1 = val1.term
qout1 <- check ctx1 sg val1 ty' qout1 <- check ctx1 sg val1 ty'
lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) ty' val1 val' lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) ty' val1 val'
let qout0' = toMaybe $ map (, val0 // one p) qout0 let qouts = qout :: catMaybes [toMaybe qout0, toMaybe qout1]
qout1' = toMaybe $ map (, val1 // one p) qout1 pure $ InfRes {type = ty, qout = lubs ctx qouts}
qouts = (qout, val) :: catMaybes [qout0', qout1']
let Just qout = lubs ctx $ map fst qouts
| Nothing => throw $ BadQtys loc "composition" ctx qouts
pure $ InfRes {type = ty, qout}
infer' ctx sg (TypeCase ty ret arms def loc) = do infer' ctx sg (TypeCase ty ret arms def loc) = do
-- if σ = 0 -- if σ = 0