[commit: ghc] master: zonkCt tries to maintain the canonical form of a Ct. (07292e9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/07292e958cb0c08705d9a694f09d9621058b16e6/ghc

>---------------------------------------------------------------

commit 07292e958cb0c08705d9a694f09d9621058b16e6
Author: Christiaan Baaij <christiaan.baaij at gmail.com>
Date:   Sat Feb 11 19:21:52 2017 -0500

    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


>---------------------------------------------------------------

07292e958cb0c08705d9a694f09d9621058b16e6
 compiler/typecheck/TcMType.hs                      | 40 +++++++++++++++++++++-
 testsuite/tests/typecheck/should_compile/T11525.hs | 26 ++++++++++++++
 .../{T11462_Plugin.hs => T11525_Plugin.hs}         |  2 +-
 testsuite/tests/typecheck/should_compile/all.T     |  3 ++
 4 files changed, 69 insertions(+), 2 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 at 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
+ at 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/T11462_Plugin.hs b/testsuite/tests/typecheck/should_compile/T11525_Plugin.hs
similarity index 91%
copy from testsuite/tests/typecheck/should_compile/T11462_Plugin.hs
copy to testsuite/tests/typecheck/should_compile/T11525_Plugin.hs
index 5d98395..bc1ffc4 100644
--- a/testsuite/tests/typecheck/should_compile/T11462_Plugin.hs
+++ b/testsuite/tests/typecheck/should_compile/T11525_Plugin.hs
@@ -1,4 +1,4 @@
-module T11462_Plugin(plugin) where
+module T11525_Plugin(plugin) where
 
 import TcRnMonad ( TcPlugin(..), TcPluginResult(..) )
 import Plugins ( defaultPlugin, Plugin(..), CommandLineOption )
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'])