Typechecker can't infer StM m Bool ~ Bool from StM m a ~ a

We found a problem where TC correctly infers StM m a ~ a but fails to infer StM m Bool ~ Bool in what appears to be the same situation. Here is a small sample showing the problem:

{-# LANGUAGE FlexibleContexts, FlexibleInstances  #-}

module Problem where

import qualified Control.Monad.STM              as STM
import           Control.Monad.STM              (STM)
import           Control.Monad.Trans.Control    (MonadBaseControl, liftBaseWith)

class MonadSTM m where liftSTM :: STM a -> m a

instance MonadSTM STM where liftSTM = id

always :: (Monad m, MonadSTM m, MonadBaseControl STM m) => m Bool -> m ()
always inv = liftBaseWith $ \runInSTM -> STM.always (runInSTM inv)

alwaysSucceeds :: (Monad m, MonadSTM m, MonadBaseControl STM m) => m a -> m ()
alwaysSucceeds inv = liftBaseWith $ \runInSTM -> STM.alwaysSucceeds (runInSTM inv)

The compiler error is

Problem.hs:15:54:
    Couldn't match type ‘Control.Monad.Trans.Control.StM m Bool’
                   with ‘Bool’
    Expected type: STM Bool
      Actual type: STM (Control.Monad.Trans.Control.StM m Bool)
    Relevant bindings include
      runInSTM :: Control.Monad.Trans.Control.RunInBase m STM
        (bound at Problem.hs:15:30)
      inv :: m Bool (bound at Problem.hs:15:8)
      always :: m Bool -> m () (bound at Problem.hs:15:1)
    In the first argument of ‘STM.always’, namely ‘(runInSTM inv)’
    In the expression: STM.always (runInSTM inv)

Function always can be made to compile by adding StM m Bool ~ Bool:

always :: (Monad m, MonadSTM m, MonadBaseControl STM m, StM m Bool ~ Bool) => m Bool -> m ()

but then the problem is just shifted to the caller:

   Couldn't match type ‘(Either [Char] Bool, Int)’ with ‘Bool’
   Expected type: Bool
     Actual type: StM (RSET TestData Int String STM) Bool
   In the second argument of ‘($)’, namely ‘always sanityCheck’
   In a stmt of a 'do' block: atomically $ always sanityCheck
   In the expression:
     do { atomically $ always sanityCheck;
          atomically $ updateTX 1 2;
          atomically stashSum }

Trac metadata

Trac field	Value
Version	7.10.2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture