diff options
author | Christiaan Baaij <christiaan.baaij@gmail.com> | 2017-02-11 19:21:52 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-02-11 19:58:34 -0500 |
commit | 07292e958cb0c08705d9a694f09d9621058b16e6 (patch) | |
tree | 4362824bc21ef87fc4b9fbd51183164d993f9920 | |
parent | 56c9bb39246f9ffd8ed41a0656bfe8e60d23be57 (diff) | |
download | haskell-07292e958cb0c08705d9a694f09d9621058b16e6.tar.gz |
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
-rw-r--r-- | compiler/typecheck/TcMType.hs | 40 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/T11525.hs | 26 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/T11525_Plugin.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 3 |
4 files changed, 82 insertions, 1 deletions
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index d9105b3f1a..56cc711195 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 0000000000..406bf5fa77 --- /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 0000000000..bc1ffc4da0 --- /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 7d2e3c664a..286ebbb1ea 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']) |