diff --git a/lib/Quox/Syntax/Qty.idr b/lib/Quox/Syntax/Qty.idr index 0db17b5..86672b6 100644 --- a/lib/Quox/Syntax/Qty.idr +++ b/lib/Quox/Syntax/Qty.idr @@ -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 diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index bfe0208..0cc2e19 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -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