Constraint invariant checking

Add Constraint.checkCtInvariants, and use it in TcInteract,
to check for any Ct invariants we care to check.

Initially I'm using it to check for homogeneity of CTyEqCan.

2 files changed, 36 insertions, 8 deletions

diff --git a/compiler/typecheck/Constraint.hs b/compiler/typecheck/Constraint.hs
index 700c024a0d..31526f9642 100644
--- a/compiler/typecheck/Constraint.hs
+++ b/compiler/typecheck/Constraint.hs
@@ -28,6 +28,7 @@ module Constraint (
         ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
         tyCoVarsOfCt, tyCoVarsOfCts,
         tyCoVarsOfCtList, tyCoVarsOfCtsList,
+        checkCtInvariants,
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,
@@ -416,6 +417,30 @@ instance Outputable Ct where
             | pend_sc   -> text "CQuantCan(psc)"
             | otherwise -> text "CQuantCan"
 
+{- *********************************************************************
+*                                                                      *
+        Invariant checking
+*                                                                      *
+********************************************************************* -}
+
+checkCtInvariants :: Ct -> a -> a
+
+checkCtInvariants _ result   -- Normal compile route picks this path always
+  | not debugIsOn = result
+
+checkCtInvariants (CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) _
+  | not (lhs_k `tcEqType` rhs_k)
+  = pprPanic "checkCtInvariants: CTyEqCan: kind mismatch" $
+    vcat [ ppr ev
+         , ppr tv <+> dcolon <+> ppr lhs_k
+         , ppr rhs <+> dcolon <+> ppr rhs_k ]
+  where
+    lhs_k = tyVarKind tv
+    rhs_k = typeKind rhs
+
+checkCtInvariants _ result
+  = result
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index a2aa82e51b..3ec8fb144b 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -403,14 +403,17 @@ runSolverPipeline pipeline workItem
        }
   where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct
                      -> TcS (StopOrContinue Ct)
-        run_pipeline [] res        = return res
-        run_pipeline _ (Stop ev s) = return (Stop ev s)
-        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
-          = do { traceTcS ("runStage " ++ stg_name ++ " {")
-                          (text "workitem   = " <+> ppr ct)
-               ; res <- stg ct
-               ; traceTcS ("end stage " ++ stg_name ++ " }") empty
-               ; run_pipeline stgs res }
+        run_pipeline _      (Stop ev s) = return (Stop ev s)
+        run_pipeline stages (ContinueWith ct)
+          = checkCtInvariants ct $
+            case stages of
+               [] -> return (ContinueWith ct)
+               (stage_name,stage) : stages
+                  -> do { traceTcS ("runStage " ++ stage_name ++ " {")
+                                   (text "workitem   = " <+> ppr ct)
+                        ; res <- stage ct
+                        ; traceTcS ("end stage " ++ stage_name ++ " }") empty
+                        ; run_pipeline stages res }
 
 {-
 Example 1: