为什么GHC发出错误的"冗余约束"在这警告?

时间:2017-01-17 19:24:07

标签: haskell ghc

根据标题,我很好奇为什么GHC在删除时会发出关于冗余约束的警告,使得代码不再编译。

{-# 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

并产生以下警告:

/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))

并删除约束会导致以下错误:

/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))

我使用GHC 8.0.1并使用-Wall进行编译。

有什么方法可以重构代码以避免警告?或者,如果不可能,那么是否有办法在每个功能的基础上使警告静音,而不是在整个模块中使用OPTIONS_GHC

编辑:使用GHC 8.0.2进行编译不再产生警告。

0 个答案:

没有答案