Skip to content

TcLevel invariants are being violated

The TcLevel invariants are clearly being violated in tcMatchesInfer and tcMatchesCheck:

-- | Rule: Match-Infer
tcMatchInfer gamma (MkMatch aps e) irs ir = do
  ps <- getPats aps
  (dlt, qs) <- tcPatsInfer gamma (zipWith (\i p -> (p, Infer i)) irs ps)
  traceTc "tcMatch - Delta returened by tcPatsInfer:" (pretty dlt)
  let givens = map (mkCt CtGiven) qs
      skols  = skolems dlt
  buildImplicIfNeeded skols givens
      $ tcExpr (modifyDelta (dlt <>) gamma) e (Infer ir)
-- | Rule: Match-Check
tcMatchCheck gamma (MkMatch aps e) psis rho = do
  (patSigmaPairs, lcl_ctxt, qs,subst) <- tcSkolAPats gamma psis aps
  (lcl_ctxt', qs') <- tcPatsCheck (modifyDelta (lcl_ctxt <>) gamma) patSigmaPairs
  let givens = map (mkCt CtGiven) (qs ++ qs')
      skols  = skolems lcl_ctxt
  buildImplicIfNeeded skols givens $
    tcExpr (modifyDelta ((lcl_ctxt' <> lcl_ctxt) <>) gamma) e
        $ Check (appTvSubstTau subst (rhoToSigma rho))

The problem is that the function that pushes the ambient TcLevel by one -- pushLevelAndCaptureCts -- is in buildImplicIfNeeded, which is clearly called after the functions that are responsible for typechecking patterns. i.e tcPatsInfer, tcPatsCheck, and tcSkolemiseAPats.

Here are the implications built for ./typechecker/test/cases/should-typecheck/myMap-infer.hs:

buildImplicIfNeeded {
 implTcLvl   = 1
 implSkolems = sk25[0] : Type
 implGivens  = []
 implStatus  = Unsolved
 implWanteds = wcImplics = []
               wcSimples = [W] mv-t36[0]:Type ~ (mv-t40[1]:Type -> mv-t41[1]:Type)
                           [W] Type ~ Type
                           [W] mv-t35[0]:Type ~ (mv-t42[1]:Type -> mv-t43[1]:Type)
                           [W] mv-t43[1]:Type ~ (mv-t44[1]:Type -> mv-t45[1]:Type)
                           [W] mv-t46[0]:Type ~ List mv-t41[1]:Type
                           [W] mv-t36[0]:Type ~ (mv-t47[1]:Type -> mv-t48[1]:Type)
                           [W] mv-t41[1]:Type ~ mv-t48[1]:Type
                           [W] mv-t47[1]:Type ~ mv-t38[0]:Type
                           [W] mv-t35[0]:Type ~ (mv-t49[1]:Type -> mv-t50[1]:Type)
                           [W] mv-t50[1]:Type ~ (mv-t51[1]:Type -> mv-t52[1]:Type)
                           [W] List mv-t41[1]:Type ~ mv-t52[1]:Type
                           [W] mv-t49[1]:Type ~ mv-t36[0]:Type
                           [W] mv-t51[1]:Type ~ List mv-t38[0]:Type
} 

buildImplicIfNeeded {
 implTcLvl   = 1
 implSkolems = sk24[0] : Type
 implGivens  = []
 implStatus  = Unsolved
 implWanteds = wcImplics = []
               wcSimples = [W] mv-t46[0]:Type ~ List mv-t57[1]:Type
}