根据标题,我很好奇为什么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进行编译不再产生警告。