zonkCt tries to maintain the canonical form of a Ct.

For example,
 - a CDictCan should stay a CDictCan;
 - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).
 - a CHoleCan should stay a CHoleCan

Why?  For CDicteqCan see Trac #11525.

Test Plan: Validate

Reviewers: austin, adamgundry, simonpj, goldfire, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3105

4 files changed, 82 insertions, 1 deletions

diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index d9105b3..56cc711 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -1355,12 +1355,50 @@ zonkSimples cts = do { cts' <- mapBagM zonkCt' cts
 zonkCt' :: Ct -> TcM Ct
 zonkCt' ct = zonkCt ct
 
+{- Note [zonkCt behaviour]
+zonkCt tries to maintain the canonical form of a Ct.  For example,
+  - a CDictCan should stay a CDictCan;
+  - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).
+  - a CHoleCan should stay a CHoleCan
+
+Why?, for example:
+- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the
+  simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,
+  constraints are zonked before being passed to the plugin. This means if we
+  don't preserve a canonical form, @expandSuperClasses@ fails to expand
+  superclasses. This is what happened in Trac #11525.
+
+- For CHoleCan, once we forget that it's a hole, we can never recover that info.
+
+NB: we do not expect to see any CFunEqCans, because zonkCt is only
+called on unflattened constraints.
+NB: Constraints are always re-flattened etc by the canonicaliser in
+@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that
+are actually in the inert set carry all the guarantees. So it is okay if zonkCt
+creates e.g. a CDictCan where the cc_tyars are /not/ function free.
+-}
 zonkCt :: Ct -> TcM Ct
 zonkCt ct@(CHoleCan { cc_ev = ev })
   = do { ev' <- zonkCtEvidence ev
        ; return $ ct { cc_ev = ev' } }
+zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
+  = do { ev'   <- zonkCtEvidence ev
+       ; args' <- mapM zonkTcType args
+       ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
+zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })
+  = do { ev'    <- zonkCtEvidence ev
+       ; tv_ty' <- zonkTcTyVar tv
+       ; case getTyVar_maybe tv_ty' of
+           Just tv' -> do { rhs' <- zonkTcType rhs
+                          ; return ct { cc_ev    = ev'
+                                      , cc_tyvar = tv'
+                                      , cc_rhs   = rhs' } }
+           Nothing  -> return (mkNonCanonical ev') }
 zonkCt ct
-  = do { fl' <- zonkCtEvidence (cc_ev ct)
+  = ASSERT( not (isCFunEqCan ct) )
+  -- We do not expect to see any CFunEqCans, because zonkCt is only called on
+  -- unflattened constraints.
+    do { fl' <- zonkCtEvidence (cc_ev ct)
        ; return (mkNonCanonical fl') }
 
 zonkCtEvidence :: CtEvidence -> TcM CtEvidence
diff --git a/testsuite/tests/typecheck/should_compile/T11525.hs b/testsuite/tests/typecheck/should_compile/T11525.hs
new file mode 100644
index 0000000..406bf5f
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11525.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds, TypeOperators, KindSignatures, TypeFamilies,
+             ConstraintKinds, FlexibleContexts #-}
+{-# OPTIONS_GHC -fplugin T11525_Plugin #-}
+module T11525 where
+
+import GHC.TypeLits
+import Data.Proxy
+
+truncateB :: KnownNat a => Proxy (a + b) -> Proxy a
+truncateB Proxy = Proxy
+
+class Bus t where
+  type AddrBits t :: Nat
+
+data MasterOut b = MasterOut
+    { adr :: Proxy (AddrBits b)
+    }
+
+type WiderAddress b b' k = ( KnownNat (AddrBits b)
+                           , AddrBits b' ~ (AddrBits b + k)
+                           )
+
+narrowAddress' :: (WiderAddress b b' k)
+               => MasterOut b'
+               -> MasterOut b
+narrowAddress' m = MasterOut { adr = truncateB (adr m) }
diff --git a/testsuite/tests/typecheck/should_compile/T11525_Plugin.hs b/testsuite/tests/typecheck/should_compile/T11525_Plugin.hs
new file mode 100644
index 0000000..bc1ffc4
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11525_Plugin.hs
@@ -0,0 +1,14 @@
+module T11525_Plugin(plugin) where
+
+import TcRnMonad ( TcPlugin(..), TcPluginResult(..) )
+import Plugins ( defaultPlugin, Plugin(..), CommandLineOption )
+
+plugin :: Plugin
+plugin = defaultPlugin { tcPlugin = Just . thePlugin }
+
+thePlugin :: [CommandLineOption] -> TcPlugin
+thePlugin opts = TcPlugin
+  { tcPluginInit  = return ()
+  , tcPluginSolve = \_ _ _ _ -> return $ TcPluginOk [] []
+  , tcPluginStop  = \_ -> return ()
+  }
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 7d2e3c6..286ebbb 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -536,3 +536,6 @@ test('T11723', normal, compile, [''])
 test('T12987', normal, compile, [''])
 test('T11736', normal, compile, [''])
 test('T13248', expect_broken(13248), compile, [''])
+test('T11525', [unless(have_dynamic(), expect_broken(10301))], multi_compile,
+     ['', [('T11525_Plugin.hs', '-package ghc'), ('T11525.hs', '')],
+      '-dynamic'])