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

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
lub : Qty -> Qty -> Maybe Qty
lub p q = Just $ if p == q then p else Any
lub : Qty -> Qty -> Qty
lub p q = if p == q then p else Any
||| to maintain subject reduction, only 0 or 1 can occur

View File

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