Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Remove Travis CI for GHC 7.6.x #228

Open
wants to merge 5 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
49 changes: 6 additions & 43 deletions src/Database/PostgreSQL/Simple/Compat.hs
Original file line number Diff line number Diff line change
Expand Up @@ -28,67 +28,30 @@ import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
import Data.Scientific (scientificBuilder)
#endif

#if __GLASGOW_HASKELL__ >= 702
import System.IO.Unsafe (unsafeDupablePerformIO)
#elif __GLASGOW_HASKELL__ >= 611
import GHC.IO (unsafeDupablePerformIO)
#else
import GHC.IOBase (unsafeDupablePerformIO)
#endif

import Data.Fixed (Pico)
#if MIN_VERSION_base(4,7,0)
import Data.Fixed (Fixed(MkFixed))
#else
import Unsafe.Coerce (unsafeCoerce)
#endif

-- | Like 'E.mask', but backported to base before version 4.3.0.
--
-- Note that the restore callback is monomorphic, unlike in 'E.mask'. This
-- could be fixed by changing the type signature, but it would require us to
-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The
-- 'withTransactionMode' function calls the restore callback only once, so we
-- don't need that polymorphism.
-- | Like 'E.mask', but with a monomorphic restore callback, unlike in
-- 'E.mask'. This could be fixed by changing the type signature, but
-- it would require us to enable the RankNTypes extension (since
-- 'E.mask' has a rank-3 type). The 'withTransactionMode' function
-- calls the restore callback only once, so we don't need that
-- polymorphism.
mask :: ((IO a -> IO a) -> IO b) -> IO b
#if MIN_VERSION_base(4,3,0)
mask io = E.mask $ \restore -> io restore
#else
mask io = do
b <- E.blocked
E.block $ io $ \m -> if b then m else E.unblock m
#endif
{-# INLINE mask #-}

#if !MIN_VERSION_base(4,5,0)
infixr 6 <>

(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}
#endif

toByteString :: Builder -> ByteString
#if MIN_VERSION_bytestring(0,10,0)
toByteString x = toStrict (toLazyByteString x)
#else
toByteString x = B.concat (toChunks (toLazyByteString x))
#endif

#if MIN_VERSION_base(4,7,0)

toPico :: Integer -> Pico
toPico = MkFixed

fromPico :: Pico -> Integer
fromPico (MkFixed i) = i

#else

toPico :: Integer -> Pico
toPico = unsafeCoerce

fromPico :: Pico -> Integer
fromPico = unsafeCoerce

#endif
17 changes: 0 additions & 17 deletions src/Database/PostgreSQL/Simple/Notification.hs
Original file line number Diff line number Diff line change
Expand Up @@ -47,8 +47,6 @@ import GHC.IO.Exception ( ioe_location )

#if defined(mingw32_HOST_OS)
import Control.Concurrent ( threadDelay )
#elif !MIN_VERSION_base(4,7,0)
import Control.Concurrent ( threadWaitRead )
#else
import GHC.Conc ( atomically )
import Control.Concurrent ( threadWaitReadSTM )
Expand Down Expand Up @@ -94,21 +92,6 @@ getNotification conn = join $ withConnection conn fetch
-- with async exceptions, whereas threadDelay can.
Just _fd -> do
return (threadDelay 1000000 >> loop)
#elif !MIN_VERSION_base(4,7,0)
-- Technically there's a race condition that is usually benign.
-- If the connection is closed or reset after we drop the
-- lock, and then the fd index is reallocated to a new
-- descriptor before we call threadWaitRead, then
-- we could end up waiting on the wrong descriptor.
--
-- Now, if the descriptor becomes readable promptly, then
-- it's no big deal as we'll wake up and notice the change
-- on the next iteration of the loop. But if are very
-- unlucky, then we could end up waiting a long time.
Just fd -> do
return $ do
threadWaitRead fd `catch` (throwIO . setIOErrorLocation)
loop
#else
-- This case fixes the race condition above. By registering
-- our interest in the descriptor before we drop the lock,
Expand Down