Why does the GHC emit the wrong warning about excessive restriction?

According to the heading, I am curious why the GHC issues a warning about excessive restriction when removing it makes the code more compiled.

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Lib where

import           Protolude hiding (from, try)

import           Control.Exception.Safe
import           Database.Esqueleto
import           Database.Persist.TH

newtype PingId =
  PingId Int
  deriving (Enum, Eq, Integral, Num, Ord, Real, Show)

data Ping = Ping
  {
  } deriving (Show)

share [mkPersist sqlSettings] [persistLowerCase|
DbPing sql=pings
|]

pingToDbPing :: Ping -> DbPing
pingToDbPing _ = undefined

dbPingToPing :: DbPing -> Either Text Ping
dbPingToPing _ = undefined

class (PersistEntity a, ToBackendKey SqlBackend a) =>
      FromPersistEntity a b | a -> b where
  fromPersistEntity :: a -> Either Text b

instance FromPersistEntity DbPing Ping where
  fromPersistEntity = dbPingToPing

type family ToKey a :: * where
  ToKey PingId = DbPingId

findById
  :: forall m key record val.
     ( Integral key
     , Key record ~ ToKey key
     , FromPersistEntity record val
     , MonadCatch m
     , MonadIO m
     , MonadReader DbConfig m
     )
  => key -> m (Either Text (Maybe val))
findById key = do
  maybeRetOrErr <-
    try
      (liftIO . evaluate =<<
       runDB
         (select $
          from $ \table -> do
            where_
              (table ^. persistIdField ==. val (toSqlKey . fromIntegral $ key))
            return table))
  case maybeRetOrErr of
    Left (e :: SomeException) -> return . Left . toS . displayException $ e
    Right [] -> return . Right $ Nothing
    Right [ret :: Entity record] ->
      return . fmap Just . fromPersistEntity . entityVal $ ret
    Right _ -> return . Left $ "impossible happened, more than one result"

data DbConfig = DbConfig
  { dbConnectionPool :: ConnectionPool
  }

runDB
  :: (MonadIO m, MonadReader DbConfig m)
  => SqlPersistT IO b -> m b
runDB q = do
  pool <- asks dbConnectionPool
  liftIO $ runSqlPool q pool

test :: IO ()
test = do
  let dbConfig = DbConfig undefined
  flip runReaderT dbConfig $ do
    pingOrErr <- findById (PingId 1)
    print pingOrErr

and issues the following warning:

/home/ppb/Code/haskell/test/src/Lib.hs:49:1: warning: [-Wredundant-constraints]
     Redundant constraint: Key record ~ ToKey key
     In the type signature for:
           findById :: (Integral key, Key record ~ ToKey key,
                        FromPersistEntity record val, MonadCatch m, MonadIO m,
                        MonadReader DbConfig m) =>
                       key -> m (Either Text (Maybe val))

and deleting the result of the constraint results in the following error:

/home/ppb/Code/haskell/test/src/Lib.hs:50:6: error:
     Could not deduce (FromPersistEntity record0 val)
      from the context: (Integral key,
                         FromPersistEntity record val,
                         MonadCatch m,
                         MonadIO m,
                         MonadReader DbConfig m)
        bound by the type signature for:
                   findById :: (Integral key, FromPersistEntity record val,
                                MonadCatch m, MonadIO m, MonadReader DbConfig m) =>
                               key -> m (Either Text (Maybe val))
        at src/Lib.hs:(50,6)-(57,39)
      The type variable ‘record0’ is ambiguous
     In the ambiguity check for ‘findById’
      To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
      In the type signature:
        findById :: forall m key record val.
                    (Integral key,
                     FromPersistEntity record val,
                     MonadCatch m,
                     MonadIO m,
                     MonadReader DbConfig m) =>
                    key -> m (Either Text (Maybe val))

I am using GHC 8.0.1 and compiling with -Wall.

Is there any way to change the structure of the code to avoid a warning? Or, if this is not possible, is there a way to disable the warning for each function, and not through the entire module with OPTIONS_GHC?


EDIT : compiling with GHC 8.0.2 no longer triggers a warning.

+4
source share

Source: https://habr.com/ru/post/1667056/


All Articles