diff --git a/Control/Applicative.hs b/Control/Applicative.hs --- a/Control/Applicative.hs +++ b/Control/Applicative.hs @@ -64,7 +64,10 @@ import GHC.Show (Show) newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } - deriving (Generic, Generic1, Monad) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Monad -- ^ @since 4.7.0.0 + ) -- | @since 2.01 instance Monad m => Functor (WrappedMonad m) where @@ -82,7 +85,9 @@ WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } - deriving (Generic, Generic1) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) -- | @since 2.01 instance Arrow a => Functor (WrappedArrow a b) where @@ -101,8 +106,15 @@ -- | Lists, but with an 'Applicative' functor based on zipping. newtype ZipList a = ZipList { getZipList :: [a] } - deriving ( Show, Eq, Ord, Read, Functor - , Foldable, Generic, Generic1) + deriving ( Show -- ^ @since 4.7.0.0 + , Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Functor -- ^ @since 2.01 + , Foldable -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) -- See Data.Traversable for Traversable instance due to import loops -- | diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -407,7 +407,7 @@ -- fdReady does the right thing, but we have to call it in a -- separate thread, otherwise threadWaitRead won't be interruptible, -- and this only works with -threaded. - | threaded = withThread (waitFd fd 0) + | threaded = withThread (waitFd fd False) | otherwise = case fd of 0 -> do _ <- hWaitForInput stdin (-1) return () @@ -428,7 +428,7 @@ threadWaitWrite :: Fd -> IO () threadWaitWrite fd #if defined(mingw32_HOST_OS) - | threaded = withThread (waitFd fd 1) + | threaded = withThread (waitFd fd True) | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else = GHC.Conc.threadWaitWrite fd @@ -444,7 +444,7 @@ threadWaitReadSTM fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing - mask_ $ void $ forkIO $ do result <- try (waitFd fd 0) + mask_ $ void $ forkIO $ do result <- try (waitFd fd False) atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of @@ -468,7 +468,7 @@ threadWaitWriteSTM fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing - mask_ $ void $ forkIO $ do result <- try (waitFd fd 1) + mask_ $ void $ forkIO $ do result <- try (waitFd fd True) atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of @@ -494,13 +494,13 @@ Right a -> return a Left e -> throwIO (e :: IOException) -waitFd :: Fd -> CInt -> IO () +waitFd :: Fd -> Bool -> IO () waitFd fd write = do throwErrnoIfMinus1_ "fdReady" $ - fdReady (fromIntegral fd) write (-1) 0 + fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0 foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> Int64 -> CInt -> IO CInt + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #endif -- --------------------------------------------------------------------------- diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs --- a/Control/Concurrent/Chan.hs +++ b/Control/Concurrent/Chan.hs @@ -50,7 +50,7 @@ data Chan a = Chan _UPK_(MVar (Stream a)) _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar - deriving (Eq) + deriving Eq -- ^ @since 4.4.0.0 type Stream a = MVar (ChItem a) @@ -106,20 +106,11 @@ -- thread holds a reference to the channel. readChan :: Chan a -> IO a readChan (Chan readVar _) = do - modifyMVarMasked readVar $ \read_end -> do -- Note [modifyMVarMasked] + modifyMVar readVar $ \read_end -> do (ChItem val new_read_end) <- readMVar read_end -- Use readMVar here, not takeMVar, -- else dupChan doesn't work return (new_read_end, val) - --- Note [modifyMVarMasked] --- This prevents a theoretical deadlock if an asynchronous exception --- happens during the readMVar while the MVar is empty. In that case --- the read_end MVar will be left empty, and subsequent readers will --- deadlock. Using modifyMVarMasked prevents this. The deadlock can --- be reproduced, but only by expanding readMVar and inserting an --- artificial yield between its takeMVar and putMVar operations. - -- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to -- either channel from then on will be available from both. Hence this creates diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs --- a/Control/Concurrent/QSem.hs +++ b/Control/Concurrent/QSem.hs @@ -29,7 +29,7 @@ import Control.Exception import Data.Maybe --- | 'QSem' is a quantity semaphore in which the resource is aqcuired +-- | 'QSem' is a quantity semaphore in which the resource is acquired -- and released in units of one. It provides guaranteed FIFO ordering -- for satisfying blocked `waitQSem` calls. -- diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs --- a/Control/Concurrent/QSemN.hs +++ b/Control/Concurrent/QSemN.hs @@ -31,7 +31,7 @@ import Control.Exception import Data.Maybe --- | 'QSemN' is a quantity semaphore in which the resource is aqcuired +-- | 'QSemN' is a quantity semaphore in which the resource is acquired -- and released in units of one. It provides guaranteed FIFO ordering -- for satisfying blocked `waitQSemN` calls. -- diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -93,9 +93,9 @@ finally, -- * Calls for GHC runtime - recSelError, recConError, irrefutPatError, runtimeError, + recSelError, recConError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, - absentError, typeError, + absentError, absentSumFieldError, typeError, nonTermination, nestedAtomically, ) where @@ -375,7 +375,7 @@ ----- -recSelError, recConError, irrefutPatError, runtimeError, +recSelError, recConError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, absentError, typeError :: Addr# -> a -- All take a UTF8-encoded C string @@ -386,7 +386,6 @@ absentError s = errorWithoutStackTrace ("Oops! Entered absent arg " ++ unpackCStringUtf8# s) nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) -irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) recConError s = throw (RecConError (untangle s "Missing field in record construction")) noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation")) patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in")) @@ -399,3 +398,7 @@ -- GHC's RTS calls this nestedAtomically :: SomeException nestedAtomically = toException NestedAtomically + +-- Introduced by unarise for unused unboxed sum fields +absentSumFieldError :: a +absentSumFieldError = absentError " in unboxed sum."# diff --git a/Control/Monad.hs b/Control/Monad.hs --- a/Control/Monad.hs +++ b/Control/Monad.hs @@ -139,11 +139,12 @@ infixr 1 <=<, >=> --- | Left-to-right Kleisli composition of monads. +-- | Left-to-right composition of Kleisli arrows. (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \x -> f x >>= g --- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped. +-- | Right-to-left composition of Kleisli arrows. @('>=>')@, with the arguments +-- flipped. -- -- Note how this operator resembles function composition @('.')@: -- @@ -152,7 +153,30 @@ (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) (<=<) = flip (>=>) --- | @'forever' act@ repeats the action infinitely. +-- | Repeat an action indefinitely. +-- +-- ==== __Examples__ +-- +-- A common use of 'forever' is to process input from network sockets, +-- 'System.IO.Handle's, and channels +-- (e.g. 'Control.Concurrent.MVar.MVar' and +-- 'Control.Concurrent.Chan.Chan'). +-- +-- For example, here is how we might implement an [echo +-- server](https://en.wikipedia.org/wiki/Echo_Protocol), using +-- 'forever' both to listen for client connections on a network socket +-- and to echo client input on client connection handles: +-- +-- @ +-- echoServer :: Socket -> IO () +-- echoServer socket = 'forever' $ do +-- client <- accept socket +-- 'Control.Concurrent.forkFinally' (echo client) (\\_ -> hClose client) +-- where +-- echo :: Handle -> IO () +-- echo client = 'forever' $ +-- hGetLine client >>= hPutStrLn client +-- @ forever :: (Applicative f) => f a -> f b {-# INLINE forever #-} forever a = let a' = a *> a' in a' @@ -283,12 +307,25 @@ -- ----------------------------------------------------------------------------- -- Other MonadPlus functions --- | Direct 'MonadPlus' equivalent of 'filter' --- @'filter'@ = @(mfilter:: (a -> Bool) -> [a] -> [a]@ --- applicable to any 'MonadPlus', for example --- @mfilter odd (Just 1) == Just 1@ --- @mfilter odd (Just 2) == Nothing@ - +-- | Direct 'MonadPlus' equivalent of 'Data.List.filter'. +-- +-- ==== __Examples__ +-- +-- The 'Data.List.filter' function is just 'mfilter' specialized to +-- the list monad: +-- +-- @ +-- 'Data.List.filter' = ( 'mfilter' :: (a -> Bool) -> [a] -> [a] ) +-- @ +-- +-- An example using 'mfilter' with the 'Maybe' monad: +-- +-- @ +-- >>> mfilter odd (Just 1) +-- Just 1 +-- >>> mfilter odd (Just 2) +-- Nothing +-- @ mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a {-# INLINABLE mfilter #-} mfilter p ma = do diff --git a/Control/Monad/Fix.hs b/Control/Monad/Fix.hs --- a/Control/Monad/Fix.hs +++ b/Control/Monad/Fix.hs @@ -28,11 +28,12 @@ import Data.Function ( fix ) import Data.Maybe import Data.Monoid ( Dual(..), Sum(..), Product(..) - , First(..), Last(..), Alt(..) ) + , First(..), Last(..), Alt(..), Ap(..) ) +import Data.Ord ( Down(..) ) import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) ) import GHC.Generics import GHC.List ( head, tail ) -import GHC.ST +import Control.Monad.ST.Imp import System.IO -- | Monads having fixed points with a \'knot-tying\' semantics. @@ -126,6 +127,10 @@ instance MonadFix f => MonadFix (Alt f) where mfix f = Alt (mfix (getAlt . f)) +-- | @since 4.12.0.0 +instance MonadFix f => MonadFix (Ap f) where + mfix f = Ap (mfix (getAp . f)) + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance MonadFix Par1 where @@ -145,3 +150,10 @@ where fstP (a :*: _) = a sndP (_ :*: b) = b + +-- Instances for Data.Ord + +-- | @since 4.12.0.0 +instance MonadFix Down where + mfix f = Down (fix (getDown . f)) + where getDown (Down x) = x diff --git a/Control/Monad/ST/Imp.hs b/Control/Monad/ST/Imp.hs --- a/Control/Monad/ST/Imp.hs +++ b/Control/Monad/ST/Imp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Unsafe #-} {-# OPTIONS_HADDOCK hide #-} @@ -34,7 +35,56 @@ unsafeSTToIO ) where -import GHC.ST ( ST, runST, fixST, unsafeInterleaveST +import GHC.ST ( ST, runST, unsafeInterleaveST , unsafeDupableInterleaveST ) -import GHC.Base ( RealWorld ) -import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) +import GHC.Base ( RealWorld, ($), return ) +import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO + , unsafeDupableInterleaveIO ) +import GHC.MVar ( readMVar, putMVar, newEmptyMVar ) +import Control.Exception.Base + ( catch, throwIO, NonTermination (..) + , BlockedIndefinitelyOnMVar (..) ) + +-- | Allow the result of a state transformer computation to be used (lazily) +-- inside the computation. +-- +-- Note that if @f@ is strict, @'fixST' f = _|_@. +fixST :: (a -> ST s a) -> ST s a +-- See Note [fixST] +fixST k = unsafeIOToST $ do + m <- newEmptyMVar + ans <- unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO NonTermination) + result <- unsafeSTToIO (k ans) + putMVar m result + return result + +{- Note [fixST] + ~~~~~~~~~~~~ + +For many years, we implemented fixST much like a pure fixpoint, +using liftST: + + fixST :: (a -> ST s a) -> ST s a + fixST k = ST $ \ s -> + let ans = liftST (k r) s + STret _ r = ans + in + case ans of STret s' x -> (# s', x #) + +We knew that lazy blackholing could cause the computation to be re-run if the +result was demanded strictly, but we thought that would be okay in the case of +ST. However, that is not the case (see Trac #15349). Notably, the first time +the computation is executed, it may mutate variables that cause it to behave +*differently* the second time it's run. That may allow it to terminate when it +should not. More frighteningly, Arseniy Alekseyev produced a somewhat contrived +example ( https://mail.haskell.org/pipermail/libraries/2018-July/028889.html ) +demonstrating that it can break reasonable assumptions in "trustworthy" code, +causing a memory safety violation. So now we implement fixST much like we do +fixIO. See also the implementation notes for fixIO. Simon Marlow wondered +whether we could get away with an IORef instead of an MVar. I believe we +cannot. The function passed to fixST may spark a parallel computation that +demands the final result. Such a computation should block until the final +result is available. +-} diff --git a/Control/Monad/Zip.hs b/Control/Monad/Zip.hs --- a/Control/Monad/Zip.hs +++ b/Control/Monad/Zip.hs @@ -21,6 +21,7 @@ import Control.Monad (liftM, liftM2) import Data.Functor.Identity import Data.Monoid +import Data.Ord ( Down(..) ) import Data.Proxy import qualified Data.List.NonEmpty as NE import GHC.Generics @@ -124,3 +125,9 @@ -- | @since 4.9.0.0 instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2 + +-- instances for Data.Ord + +-- | @since 4.12.0.0 +instance MonadZip Down where + mzipWith = liftM2 diff --git a/Data/Bits.hs b/Data/Bits.hs --- a/Data/Bits.hs +++ b/Data/Bits.hs @@ -190,8 +190,12 @@ {-| Return the number of bits in the type of the argument. The actual value of the argument is ignored. The function 'bitSize' is undefined for types that do not have a fixed bitsize, like 'Integer'. + + Default implementation based upon 'bitSizeMaybe' provided since + 4.12.0.0. -} bitSize :: a -> Int + bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b) {-| Return 'True' if the argument is a signed type. The actual value of the argument is ignored -} @@ -535,6 +539,74 @@ bitSizeMaybe _ = Nothing bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0 +instance Bits Natural where + (.&.) = andNatural + (.|.) = orNatural + xor = xorNatural + complement _ = errorWithoutStackTrace + "Bits.complement: Natural complement undefined" + shift x i + | i >= 0 = shiftLNatural x i + | otherwise = shiftRNatural x (negate i) + testBit x i = testBitNatural x i + zeroBits = wordToNaturalBase 0## + clearBit x i = x `xor` (bit i .&. x) + + bit (I# i#) = bitNatural i# + popCount x = popCountNatural x + + rotate x i = shift x i -- since an Natural never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" + isSigned _ = False +#else +-- | @since 4.8.0.0 +instance Bits Natural where + Natural n .&. Natural m = Natural (n .&. m) + {-# INLINE (.&.) #-} + Natural n .|. Natural m = Natural (n .|. m) + {-# INLINE (.|.) #-} + xor (Natural n) (Natural m) = Natural (xor n m) + {-# INLINE xor #-} + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" + {-# INLINE complement #-} + shift (Natural n) = Natural . shift n + {-# INLINE shift #-} + rotate (Natural n) = Natural . rotate n + {-# INLINE rotate #-} + bit = Natural . bit + {-# INLINE bit #-} + setBit (Natural n) = Natural . setBit n + {-# INLINE setBit #-} + clearBit (Natural n) = Natural . clearBit n + {-# INLINE clearBit #-} + complementBit (Natural n) = Natural . complementBit n + {-# INLINE complementBit #-} + testBit (Natural n) = testBit n + {-# INLINE testBit #-} + bitSizeMaybe _ = Nothing + {-# INLINE bitSizeMaybe #-} + bitSize = errorWithoutStackTrace "Natural: bitSize" + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + shiftL (Natural n) = Natural . shiftL n + {-# INLINE shiftL #-} + shiftR (Natural n) = Natural . shiftR n + {-# INLINE shiftR #-} + rotateL (Natural n) = Natural . rotateL n + {-# INLINE rotateL #-} + rotateR (Natural n) = Natural . rotateR n + {-# INLINE rotateR #-} + popCount (Natural n) = popCount n + {-# INLINE popCount #-} + zeroBits = Natural 0 + +#endif ----------------------------------------------------------------------------- diff --git a/Data/Complex.hs b/Data/Complex.hs --- a/Data/Complex.hs +++ b/Data/Complex.hs @@ -55,11 +55,23 @@ -- has the phase of @z@, but unit magnitude. -- -- The 'Foldable' and 'Traversable' instances traverse the real part first. +-- +-- Note that `Complex`'s instances inherit the deficiencies from the type +-- parameter's. For example, @Complex Float@'s 'Ord' instance has similar +-- problems to `Float`'s. data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. - deriving (Eq, Show, Read, Data, Generic, Generic1 - , Functor, Foldable, Traversable) + deriving ( Eq -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Data -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Foldable -- ^ @since 4.9.0.0 + , Traversable -- ^ @since 4.9.0.0 + ) -- ----------------------------------------------------------------------------- -- Functions over Complex diff --git a/Data/Data.hs b/Data/Data.hs --- a/Data/Data.hs +++ b/Data/Data.hs @@ -4,12 +4,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- @@ -126,7 +126,6 @@ import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num -import GHC.Natural import GHC.Read import GHC.Show import Text.Read( reads ) @@ -511,7 +510,7 @@ , datarep :: DataRep } - deriving Show + deriving Show -- ^ @since 4.0.0.0 -- | Representation of constructors. Note that equality on constructors -- with different types may not work -- i.e. the constructors for 'False' and @@ -543,7 +542,9 @@ | CharRep | NoRep - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) -- The list of constructors could be an array, a balanced tree, or others. @@ -553,7 +554,9 @@ | FloatConstr Rational | CharConstr Char - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) -- | Unique index for datatype constructors, @@ -565,7 +568,9 @@ data Fixity = Prefix | Infix -- Later: add associativity and precedence - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) ------------------------------------------------------------------------------ @@ -1277,6 +1282,9 @@ -- | @since 4.8.0.0 deriving instance (Data (f a), Data a, Typeable f) => Data (Alt f a) +-- | @since 4.12.0.0 +deriving instance (Data (f a), Data a, Typeable f) => Data (Ap f a) + ---------------------------------------------------------------------------- -- Data instances for GHC.Generics representations @@ -1301,7 +1309,7 @@ => Data ((f :+: g) p) -- | @since 4.9.0.0 -deriving instance (Typeable (f :: * -> *), Typeable (g :: * -> *), +deriving instance (Typeable (f :: Type -> Type), Typeable (g :: Type -> Type), Data p, Data (f (g p))) => Data ((f :.: g) p) @@ -1326,3 +1334,9 @@ -- | @since 4.9.0.0 deriving instance Data DecidedStrictness + +---------------------------------------------------------------------------- +-- Data instances for Data.Ord + +-- | @since 4.12.0.0 +deriving instance Data a => Data (Down a) diff --git a/Data/Either.hs b/Data/Either.hs --- a/Data/Either.hs +++ b/Data/Either.hs @@ -123,7 +123,11 @@ -} data Either a b = Left a | Right b - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 3.0 + , Show -- ^ @since 3.0 + ) -- | @since 3.0 instance Functor (Either a) where @@ -336,4 +340,3 @@ prop_partitionEithers x = partitionEithers x == (lefts x, rights x) -} - diff --git a/Data/Fixed.hs b/Data/Fixed.hs --- a/Data/Fixed.hs +++ b/Data/Fixed.hs @@ -57,8 +57,10 @@ f = div' n d -- | The type parameter should be an instance of 'HasResolution'. -newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0 - deriving (Eq,Ord) +newtype Fixed a = MkFixed Integer + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) -- We do this because the automatically derived Data instance requires (Data a) context. -- Our manual instance has the more general (Typeable a) context. diff --git a/Data/Foldable.hs b/Data/Foldable.hs --- a/Data/Foldable.hs +++ b/Data/Foldable.hs @@ -299,11 +299,27 @@ -- | @since 4.9.0.0 instance Foldable NonEmpty where foldr f z ~(a :| as) = f a (List.foldr f z as) - foldl f z ~(a :| as) = List.foldl f (f z a) as - foldl1 f ~(a :| as) = List.foldl f a as + foldl f z (a :| as) = List.foldl f (f z a) as + foldl1 f (a :| as) = List.foldl f a as + + -- GHC isn't clever enough to transform the default definition + -- into anything like this, so we'd end up shuffling a bunch of + -- Maybes around. + foldr1 f (p :| ps) = foldr go id ps p + where + go x r prev = f prev (r x) + + -- We used to say + -- + -- length (_ :| as) = 1 + length as + -- + -- but the default definition is better, counting from 1. + -- + -- The default definition also works great for null and foldl'. + -- As usual for cons lists, foldr' is basically hopeless. + foldMap f ~(a :| as) = f a `mappend` foldMap f as fold ~(m :| ms) = m `mappend` fold ms - length (_ :| as) = 1 + List.length as toList ~(a :| as) = a : as -- | @since 4.7.0.0 @@ -420,6 +436,14 @@ instance Foldable Last where foldMap f = foldMap f . getLast +-- | @since 4.12.0.0 +instance (Foldable f) => Foldable (Alt f) where + foldMap f = foldMap f . getAlt + +-- | @since 4.12.0.0 +instance (Foldable f) => Foldable (Ap f) where + foldMap f = foldMap f . getAp + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance Foldable U1 where @@ -439,20 +463,51 @@ sum _ = 0 product _ = 1 +-- | @since 4.9.0.0 deriving instance Foldable V1 + +-- | @since 4.9.0.0 deriving instance Foldable Par1 + +-- | @since 4.9.0.0 deriving instance Foldable f => Foldable (Rec1 f) + +-- | @since 4.9.0.0 deriving instance Foldable (K1 i c) + +-- | @since 4.9.0.0 deriving instance Foldable f => Foldable (M1 i c f) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :+: g) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :*: g) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :.: g) + +-- | @since 4.9.0.0 deriving instance Foldable UAddr + +-- | @since 4.9.0.0 deriving instance Foldable UChar + +-- | @since 4.9.0.0 deriving instance Foldable UDouble + +-- | @since 4.9.0.0 deriving instance Foldable UFloat + +-- | @since 4.9.0.0 deriving instance Foldable UInt + +-- | @since 4.9.0.0 deriving instance Foldable UWord + +-- Instances for Data.Ord +-- | @since 4.12.0.0 +deriving instance Foldable Down -- | Monadic fold over the elements of a structure, -- associating to the right, i.e. from right to left. diff --git a/Data/Function.hs b/Data/Function.hs --- a/Data/Function.hs +++ b/Data/Function.hs @@ -50,18 +50,21 @@ fix :: (a -> a) -> a fix f = let x = f x in x --- | @((==) \`on\` f) x y = f x == f y@ +-- | @'on' b u x y@ runs the binary function `b` /on/ the results of applying unary function `u` to two arguments `x` and `y`. From the opposite perspective, it transforms two inputs and combines the outputs. -- +-- @((+) \``on`\` f) x y = f x + f y@ +-- -- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@. - +-- -- Algebraic properties: -- --- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@) +-- * @(*) \`on\` 'id' = (*) -- (if (*) ∉ {⊥, 'const' ⊥})@ -- -- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@ -- -- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@ - +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +(.*.) `on` f = \x y -> f x .*. f y -- Proofs (so that I don't have to edit the test-suite): -- (*) `on` id @@ -101,9 +104,6 @@ -- (\h (*) -> (*) `on` h) (g . f) -- = -- flip on (g . f) - -on :: (b -> b -> c) -> (a -> b) -> a -> a -> c -(.*.) `on` f = \x y -> f x .*. f y -- | '&' is a reverse application operator. This provides notational diff --git a/Data/Functor/Classes.hs b/Data/Functor/Classes.hs --- a/Data/Functor/Classes.hs +++ b/Data/Functor/Classes.hs @@ -70,6 +70,7 @@ import Data.Proxy (Proxy(Proxy)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (mappend) +import Data.Ord (Down(Down)) import GHC.Read (expectP, list, paren) @@ -643,6 +644,24 @@ liftReadListPrec = liftReadListPrecDefault liftReadList = liftReadListDefault + +-- | @since 4.12.0.0 +instance Eq1 Down where + liftEq eq (Down x) (Down y) = eq x y + +-- | @since 4.12.0.0 +instance Ord1 Down where + liftCompare comp (Down x) (Down y) = comp x y + +-- | @since 4.12.0.0 +instance Read1 Down where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Down" Down + +-- | @since 4.12.0.0 +instance Show1 Down where + liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x + -- Building blocks diff --git a/Data/Functor/Compose.hs b/Data/Functor/Compose.hs --- a/Data/Functor/Compose.hs +++ b/Data/Functor/Compose.hs @@ -38,7 +38,10 @@ -- The composition of applicative functors is always applicative, -- but the composition of monads is not always a monad. newtype Compose f g a = Compose { getCompose :: f (g a) } - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- Instances of lifted Prelude classes diff --git a/Data/Functor/Const.hs b/Data/Functor/Const.hs --- a/Data/Functor/Const.hs +++ b/Data/Functor/Const.hs @@ -37,9 +37,26 @@ -- | The 'Const' functor. newtype Const a b = Const { getConst :: a } - deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional - , Generic, Generic1, Integral, Ix, Semigroup, Monoid, Num, Ord - , Real, RealFrac, RealFloat, Storable) + deriving ( Bits -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , FiniteBits -- ^ @since 4.9.0.0 + , Floating -- ^ @since 4.9.0.0 + , Fractional -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Integral -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.9.0.0 + , Monoid -- ^ @since 4.9.0.0 + , Num -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Real -- ^ @since 4.9.0.0 + , RealFrac -- ^ @since 4.9.0.0 + , RealFloat -- ^ @since 4.9.0.0 + , Storable -- ^ @since 4.9.0.0 + ) -- | This instance would be equivalent to the derived instances of the -- 'Const' newtype if the 'runConst' field were removed diff --git a/Data/Functor/Contravariant.hs b/Data/Functor/Contravariant.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Contravariant.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Contravariant +-- Copyright : (C) 2007-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@, +-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor' +-- the definition of 'Contravariant' for a given ADT is unambiguous. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +module Data.Functor.Contravariant ( + -- * Contravariant Functors + Contravariant(..) + , phantom + + -- * Operators + , (>$<), (>$$<), ($<) + + -- * Predicates + , Predicate(..) + + -- * Comparisons + , Comparison(..) + , defaultComparison + + -- * Equivalence Relations + , Equivalence(..) + , defaultEquivalence + , comparisonEquivalence + + -- * Dual arrows + , Op(..) + ) where + +import Control.Applicative +import Control.Category +import Data.Function (on) + +import Data.Functor.Product +import Data.Functor.Sum +import Data.Functor.Compose + +import Data.Monoid (Alt(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Proxy +import GHC.Generics + +import Prelude hiding ((.),id) + +-- | The class of contravariant functors. +-- +-- Whereas in Haskell, one can think of a 'Functor' as containing or producing +-- values, a contravariant functor is a functor that can be thought of as +-- /consuming/ values. +-- +-- As an example, consider the type of predicate functions @a -> Bool@. One +-- such predicate might be @negative x = x < 0@, which +-- classifies integers as to whether they are negative. However, given this +-- predicate, we can re-use it in other situations, providing we have a way to +-- map values /to/ integers. For instance, we can use the @negative@ predicate +-- on a person's bank balance to work out if they are currently overdrawn: +-- +-- @ +-- newtype Predicate a = Predicate { getPredicate :: a -> Bool } +-- +-- instance Contravariant Predicate where +-- contramap f (Predicate p) = Predicate (p . f) +-- | `- First, map the input... +-- `----- then apply the predicate. +-- +-- overdrawn :: Predicate Person +-- overdrawn = contramap personBankBalance negative +-- @ +-- +-- Any instance should be subject to the following laws: +-- +-- > contramap id = id +-- > contramap f . contramap g = contramap (g . f) +-- +-- Note, that the second law follows from the free theorem of the type of +-- 'contramap' and the first law, so you need only check that the former +-- condition holds. + +class Contravariant f where + contramap :: (a -> b) -> f b -> f a + + -- | Replace all locations in the output with the same value. + -- The default definition is @'contramap' . 'const'@, but this may be + -- overridden with a more efficient version. + (>$) :: b -> f b -> f a + (>$) = contramap . const + +-- | If 'f' is both 'Functor' and 'Contravariant' then by the time you factor +-- in the laws of each of those classes, it can't actually use its argument in +-- any meaningful capacity. +-- +-- This method is surprisingly useful. Where both instances exist and are +-- lawful we have the following laws: +-- +-- @ +-- 'fmap' f ≡ 'phantom' +-- 'contramap' f ≡ 'phantom' +-- @ +phantom :: (Functor f, Contravariant f) => f a -> f b +phantom x = () <$ x $< () + +infixl 4 >$, $<, >$<, >$$< + +-- | This is '>$' with its arguments flipped. +($<) :: Contravariant f => f b -> b -> f a +($<) = flip (>$) + +-- | This is an infix alias for 'contramap'. +(>$<) :: Contravariant f => (a -> b) -> f b -> f a +(>$<) = contramap + +-- | This is an infix version of 'contramap' with the arguments flipped. +(>$$<) :: Contravariant f => f b -> (a -> b) -> f a +(>$$<) = flip contramap + +deriving instance Contravariant f => Contravariant (Alt f) +deriving instance Contravariant f => Contravariant (Rec1 f) +deriving instance Contravariant f => Contravariant (M1 i c f) + +instance Contravariant V1 where + contramap _ x = case x of + +instance Contravariant U1 where + contramap _ _ = U1 + +instance Contravariant (K1 i c) where + contramap _ (K1 c) = K1 c + +instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where + contramap f (xs :*: ys) = contramap f xs :*: contramap f ys + +instance (Functor f, Contravariant g) => Contravariant (f :.: g) where + contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg) + +instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where + contramap f (L1 xs) = L1 (contramap f xs) + contramap f (R1 ys) = R1 (contramap f ys) + +instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where + contramap f (InL xs) = InL (contramap f xs) + contramap f (InR ys) = InR (contramap f ys) + +instance (Contravariant f, Contravariant g) + => Contravariant (Product f g) where + contramap f (Pair a b) = Pair (contramap f a) (contramap f b) + +instance Contravariant (Const a) where + contramap _ (Const a) = Const a + +instance (Functor f, Contravariant g) => Contravariant (Compose f g) where + contramap f (Compose fga) = Compose (fmap (contramap f) fga) + +instance Contravariant Proxy where + contramap _ _ = Proxy + +newtype Predicate a = Predicate { getPredicate :: a -> Bool } + +-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to the input of the predicate. +instance Contravariant Predicate where + contramap f g = Predicate $ getPredicate g . f + +instance Semigroup (Predicate a) where + Predicate p <> Predicate q = Predicate $ \a -> p a && q a + +instance Monoid (Predicate a) where + mempty = Predicate $ const True + +-- | Defines a total ordering on a type as per 'compare'. +-- +-- This condition is not checked by the types. You must ensure that the +-- supplied values are valid total orderings yourself. +newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering } + +deriving instance Semigroup (Comparison a) +deriving instance Monoid (Comparison a) + +-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to each input of the comparison function. +instance Contravariant Comparison where + contramap f g = Comparison $ on (getComparison g) f + +-- | Compare using 'compare'. +defaultComparison :: Ord a => Comparison a +defaultComparison = Comparison compare + +-- | This data type represents an equivalence relation. +-- +-- Equivalence relations are expected to satisfy three laws: +-- +-- __Reflexivity__: +-- +-- @ +-- 'getEquivalence' f a a = True +-- @ +-- +-- __Symmetry__: +-- +-- @ +-- 'getEquivalence' f a b = 'getEquivalence' f b a +-- @ +-- +-- __Transitivity__: +-- +-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' +-- then so is @'getEquivalence' f a c@. +-- +-- The types alone do not enforce these laws, so you'll have to check them +-- yourself. +newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool } + +-- | Equivalence relations are 'Contravariant', because you can +-- apply the contramapped function to each input to the equivalence +-- relation. +instance Contravariant Equivalence where + contramap f g = Equivalence $ on (getEquivalence g) f + +instance Semigroup (Equivalence a) where + Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b + +instance Monoid (Equivalence a) where + mempty = Equivalence (\_ _ -> True) + +-- | Check for equivalence with '=='. +-- +-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@. +defaultEquivalence :: Eq a => Equivalence a +defaultEquivalence = Equivalence (==) + +comparisonEquivalence :: Comparison a -> Equivalence a +comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ + +-- | Dual function arrows. +newtype Op a b = Op { getOp :: b -> a } + +deriving instance Semigroup a => Semigroup (Op a b) +deriving instance Monoid a => Monoid (Op a b) + +instance Category Op where + id = Op id + Op f . Op g = Op (g . f) + +instance Contravariant (Op a) where + contramap f g = Op (getOp g . f) + +instance Num a => Num (Op a b) where + Op f + Op g = Op $ \a -> f a + g a + Op f * Op g = Op $ \a -> f a * g a + Op f - Op g = Op $ \a -> f a - g a + abs (Op f) = Op $ abs . f + signum (Op f) = Op $ signum . f + fromInteger = Op . const . fromInteger + +instance Fractional a => Fractional (Op a b) where + Op f / Op g = Op $ \a -> f a / g a + recip (Op f) = Op $ recip . f + fromRational = Op . const . fromRational + +instance Floating a => Floating (Op a b) where + pi = Op $ const pi + exp (Op f) = Op $ exp . f + sqrt (Op f) = Op $ sqrt . f + log (Op f) = Op $ log . f + sin (Op f) = Op $ sin . f + tan (Op f) = Op $ tan . f + cos (Op f) = Op $ cos . f + asin (Op f) = Op $ asin . f + atan (Op f) = Op $ atan . f + acos (Op f) = Op $ acos . f + sinh (Op f) = Op $ sinh . f + tanh (Op f) = Op $ tanh . f + cosh (Op f) = Op $ cosh . f + asinh (Op f) = Op $ asinh . f + atanh (Op f) = Op $ atanh . f + acosh (Op f) = Op $ acosh . f + Op f ** Op g = Op $ \a -> f a ** g a + logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a) diff --git a/Data/Functor/Identity.hs b/Data/Functor/Identity.hs --- a/Data/Functor/Identity.hs +++ b/Data/Functor/Identity.hs @@ -57,9 +57,26 @@ -- -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a } - deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional - , Generic, Generic1, Integral, Ix, Semigroup, Monoid, Num, Ord - , Real, RealFrac, RealFloat, Storable) + deriving ( Bits -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.8.0.0 + , FiniteBits -- ^ @since 4.9.0.0 + , Floating -- ^ @since 4.9.0.0 + , Fractional -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.8.0.0 + , Generic1 -- ^ @since 4.8.0.0 + , Integral -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.9.0.0 + , Monoid -- ^ @since 4.9.0.0 + , Num -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.8.0.0 + , Real -- ^ @since 4.9.0.0 + , RealFrac -- ^ @since 4.9.0.0 + , RealFloat -- ^ @since 4.9.0.0 + , Storable -- ^ @since 4.9.0.0 + ) -- | This instance would be equivalent to the derived instances of the -- 'Identity' newtype if the 'runIdentity' field were removed diff --git a/Data/Functor/Product.hs b/Data/Functor/Product.hs --- a/Data/Functor/Product.hs +++ b/Data/Functor/Product.hs @@ -35,7 +35,10 @@ -- | Lifted product of functors. data Product f g a = Pair (f a) (g a) - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where diff --git a/Data/Functor/Sum.hs b/Data/Functor/Sum.hs --- a/Data/Functor/Sum.hs +++ b/Data/Functor/Sum.hs @@ -31,7 +31,10 @@ -- | Lifted sum of functors. data Sum f g a = InL (f a) | InR (g a) - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where diff --git a/Data/Kind.hs b/Data/Kind.hs --- a/Data/Kind.hs +++ b/Data/Kind.hs @@ -14,6 +14,6 @@ -- @since 4.9.0.0 ----------------------------------------------------------------------------- -module Data.Kind ( Type, Constraint, type (*), type (★) ) where +module Data.Kind ( Type, Constraint ) where import GHC.Types diff --git a/Data/Monoid.hs b/Data/Monoid.hs --- a/Data/Monoid.hs +++ b/Data/Monoid.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | @@ -38,15 +38,21 @@ First(..), Last(..), -- * 'Alternative' wrapper - Alt (..) + Alt(..), + -- * 'Applicative' wrapper + Ap(..) ) where -- Push down the module in the dependency hierarchy. import GHC.Base hiding (Any) +import GHC.Enum +import GHC.Generics +import GHC.Num import GHC.Read import GHC.Show -import GHC.Generics +import Control.Monad.Fail (MonadFail) + import Data.Semigroup.Internal -- $MaybeExamples @@ -88,9 +94,27 @@ -- -- >>> getFirst (First (Just "hello") <> First Nothing <> First (Just "world")) -- Just "hello" +-- +-- Use of this type is discouraged. Note the following equivalence: +-- +-- > Data.Monoid.First x === Maybe (Data.Semigroup.First x) +-- +-- In addition to being equivalent in the structural sense, the two +-- also have 'Monoid' instances that behave the same. This type will +-- be marked deprecated in GHC 8.8, and removed in GHC 8.10. +-- Users are advised to use the variant from "Data.Semigroup" and wrap +-- it in 'Maybe'. newtype First a = First { getFirst :: Maybe a } - deriving (Eq, Ord, Read, Show, Generic, Generic1, - Functor, Applicative, Monad) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + ) -- | @since 4.9.0.0 instance Semigroup (First a) where @@ -109,9 +133,27 @@ -- -- >>> getLast (Last (Just "hello") <> Last Nothing <> Last (Just "world")) -- Just "world" +-- +-- Use of this type is discouraged. Note the following equivalence: +-- +-- > Data.Monoid.Last x === Maybe (Data.Semigroup.Last x) +-- +-- In addition to being equivalent in the structural sense, the two +-- also have 'Monoid' instances that behave the same. This type will +-- be marked deprecated in GHC 8.8, and removed in GHC 8.10. +-- Users are advised to use the variant from "Data.Semigroup" and wrap +-- it in 'Maybe'. newtype Last a = Last { getLast :: Maybe a } - deriving (Eq, Ord, Read, Show, Generic, Generic1, - Functor, Applicative, Monad) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + ) -- | @since 4.9.0.0 instance Semigroup (Last a) where @@ -123,7 +165,47 @@ instance Monoid (Last a) where mempty = Last Nothing +-- | This data type witnesses the lifting of a 'Monoid' into an +-- 'Applicative' pointwise. +-- +-- @since 4.12.0.0 +newtype Ap f a = Ap { getAp :: f a } + deriving ( Alternative -- ^ @since 4.12.0.0 + , Applicative -- ^ @since 4.12.0.0 + , Enum -- ^ @since 4.12.0.0 + , Eq -- ^ @since 4.12.0.0 + , Functor -- ^ @since 4.12.0.0 + , Generic -- ^ @since 4.12.0.0 + , Generic1 -- ^ @since 4.12.0.0 + , Monad -- ^ @since 4.12.0.0 + , MonadFail -- ^ @since 4.12.0.0 + , MonadPlus -- ^ @since 4.12.0.0 + , Ord -- ^ @since 4.12.0.0 + , Read -- ^ @since 4.12.0.0 + , Show -- ^ @since 4.12.0.0 + ) +-- | @since 4.12.0.0 +instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where + (Ap x) <> (Ap y) = Ap $ liftA2 (<>) x y + +-- | @since 4.12.0.0 +instance (Applicative f, Monoid a) => Monoid (Ap f a) where + mempty = Ap $ pure mempty + +-- | @since 4.12.0.0 +instance (Applicative f, Bounded a) => Bounded (Ap f a) where + minBound = pure minBound + maxBound = pure maxBound + +-- | @since 4.12.0.0 +instance (Applicative f, Num a) => Num (Ap f a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum {- {-------------------------------------------------------------------- diff --git a/Data/Ord.hs b/Data/Ord.hs --- a/Data/Ord.hs +++ b/Data/Ord.hs @@ -48,12 +48,12 @@ -- @since 4.6.0.0 newtype Down a = Down a deriving - ( Eq - , Show -- ^ @since 4.7.0.0 - , Read -- ^ @since 4.7.0.0 - , Num -- ^ @since 4.11.0.0 + ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.11.0.0 , Semigroup -- ^ @since 4.11.0.0 - , Monoid -- ^ @since 4.11.0.0 + , Monoid -- ^ @since 4.11.0.0 ) -- | @since 4.6.0.0 diff --git a/Data/Proxy.hs b/Data/Proxy.hs --- a/Data/Proxy.hs +++ b/Data/Proxy.hs @@ -53,13 +53,13 @@ -- -- >>> Proxy :: Proxy complicatedStructure -- Proxy -data Proxy t = Proxy deriving ( Bounded - , Read -- ^ @since 4.7.0.0 +data Proxy t = Proxy deriving ( Bounded -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 ) -- | A concrete, promotable proxy type, for use at the kind level -- There are no instances for this because it is intended at the kind level only -data KProxy (t :: *) = KProxy +data KProxy (t :: Type) = KProxy -- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t) -- interchangeably, so all of these instances are hand-written to be diff --git a/Data/Semigroup.hs b/Data/Semigroup.hs --- a/Data/Semigroup.hs +++ b/Data/Semigroup.hs @@ -95,7 +95,15 @@ diff = Endo . (<>) newtype Min a = Min { getMin :: a } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Min a) where @@ -158,7 +166,15 @@ fromInteger = Min . fromInteger newtype Max a = Max { getMax :: a } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Max a) where @@ -222,7 +238,12 @@ -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be -- placed inside 'Min' and 'Max' to compute an arg min or arg max. data Arg a b = Arg a b deriving - (Show, Read, Data, Generic, Generic1) + ( Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) type ArgMin a b = Min (Arg a b) type ArgMax a b = Max (Arg a b) @@ -267,8 +288,16 @@ -- | Use @'Option' ('First' a)@ to get the behavior of -- 'Data.Monoid.First' from "Data.Monoid". -newtype First a = First { getFirst :: a } deriving - (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) +newtype First a = First { getFirst :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (First a) where @@ -317,8 +346,16 @@ -- | Use @'Option' ('Last' a)@ to get the behavior of -- 'Data.Monoid.Last' from "Data.Monoid" -newtype Last a = Last { getLast :: a } deriving - (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) +newtype Last a = Last { getLast :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Last a) where @@ -371,7 +408,15 @@ -- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of -- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future. newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Monoid m => Semigroup (WrappedMonoid m) where @@ -410,9 +455,21 @@ -- underlying 'Monoid'. -- -- Ideally, this type would not exist at all and we would just fix the --- 'Monoid' instance of 'Maybe' +-- 'Monoid' instance of 'Maybe'. +-- +-- In GHC 8.4 and higher, the 'Monoid' instance for 'Maybe' has been +-- corrected to lift a 'Semigroup' instance instead of a 'Monoid' +-- instance. Consequently, this type is no longer useful. It will be +-- marked deprecated in GHC 8.8 and removed in GHC 8.10. newtype Option a = Option { getOption :: Maybe a } - deriving (Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Functor Option where diff --git a/Data/Semigroup/Internal.hs b/Data/Semigroup/Internal.hs --- a/Data/Semigroup/Internal.hs +++ b/Data/Semigroup/Internal.hs @@ -108,7 +108,14 @@ -- >>> getDual (mappend (Dual "Hello") (Dual "World")) -- "WorldHello" newtype Dual a = Dual { getDual :: a } - deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) -- | @since 4.9.0.0 instance Semigroup a => Semigroup (Dual a) where @@ -138,7 +145,8 @@ -- >>> appEndo computation "Haskell" -- "Hello, Haskell!" newtype Endo a = Endo { appEndo :: a -> a } - deriving (Generic) + deriving ( Generic -- ^ @since 4.7.0.0 + ) -- | @since 4.9.0.0 instance Semigroup (Endo a) where @@ -157,7 +165,13 @@ -- >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8])) -- False newtype All = All { getAll :: Bool } - deriving (Eq, Ord, Read, Show, Bounded, Generic) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + ) -- | @since 4.9.0.0 instance Semigroup All where @@ -176,7 +190,13 @@ -- >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8])) -- True newtype Any = Any { getAny :: Bool } - deriving (Eq, Ord, Read, Show, Bounded, Generic) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + ) -- | @since 4.9.0.0 instance Semigroup Any where @@ -192,7 +212,15 @@ -- >>> getSum (Sum 1 <> Sum 2 <> mempty) -- 3 newtype Sum a = Sum { getSum :: a } - deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.7.0.0 + ) -- | @since 4.9.0.0 instance Num a => Semigroup (Sum a) where @@ -221,7 +249,15 @@ -- >>> getProduct (Product 3 <> Product 4 <> mempty) -- 12 newtype Product a = Product { getProduct :: a } - deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.7.0.0 + ) -- | @since 4.9.0.0 instance Num a => Semigroup (Product a) where @@ -251,8 +287,20 @@ -- -- @since 4.8.0.0 newtype Alt f a = Alt {getAlt :: f a} - deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum, - Monad, MonadPlus, Applicative, Alternative, Functor) + deriving ( Generic -- ^ @since 4.8.0.0 + , Generic1 -- ^ @since 4.8.0.0 + , Read -- ^ @since 4.8.0.0 + , Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + , Num -- ^ @since 4.8.0.0 + , Enum -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + , MonadPlus -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Alternative -- ^ @since 4.8.0.0 + , Functor -- ^ @since 4.8.0.0 + ) -- | @since 4.9.0.0 instance Alternative f => Semigroup (Alt f a) where diff --git a/Data/Semigroup/Internal.hs-boot b/Data/Semigroup/Internal.hs-boot --- a/Data/Semigroup/Internal.hs-boot +++ b/Data/Semigroup/Internal.hs-boot @@ -4,6 +4,7 @@ import {-# SOURCE #-} GHC.Real (Integral) import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe) +import GHC.Integer () -- Note [Depend on GHC.Integer] stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a diff --git a/Data/String.hs b/Data/String.hs --- a/Data/String.hs +++ b/Data/String.hs @@ -88,4 +88,6 @@ -- | @since 4.9.0.0 deriving instance IsString a => IsString (Const a b) + +-- | @since 4.9.0.0 deriving instance IsString a => IsString (Identity a) diff --git a/Data/Traversable.hs b/Data/Traversable.hs --- a/Data/Traversable.hs +++ b/Data/Traversable.hs @@ -60,7 +60,9 @@ import Data.Functor import Data.Functor.Identity ( Identity(..) ) import Data.Functor.Utils ( StateL(..), StateR(..) ) -import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) ) +import Data.Monoid ( Dual(..), Sum(..), Product(..), + First(..), Last(..), Alt(..), Ap(..) ) +import Data.Ord ( Down(..) ) import Data.Proxy ( Proxy(..) ) import GHC.Arr @@ -163,7 +165,7 @@ traverse f = sequenceA . fmap f -- | Evaluate each action in the structure from left to right, and - -- and collect the results. For a version that ignores the results + -- collect the results. For a version that ignores the results -- see 'Data.Foldable.sequenceA_'. sequenceA :: Applicative f => t (f a) -> f (t a) {-# INLINE sequenceA #-} -- See Note [Inline default methods] @@ -289,12 +291,22 @@ instance Traversable Last where traverse f (Last x) = Last <$> traverse f x +-- | @since 4.12.0.0 +instance (Traversable f) => Traversable (Alt f) where + traverse f (Alt x) = Alt <$> traverse f x + +-- | @since 4.12.0.0 +instance (Traversable f) => Traversable (Ap f) where + traverse f (Ap x) = Ap <$> traverse f x + -- | @since 4.9.0.0 instance Traversable ZipList where traverse f (ZipList x) = ZipList <$> traverse f x +-- | @since 4.9.0.0 deriving instance Traversable Identity + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance Traversable U1 where @@ -307,20 +319,51 @@ sequence _ = pure U1 {-# INLINE sequence #-} +-- | @since 4.9.0.0 deriving instance Traversable V1 + +-- | @since 4.9.0.0 deriving instance Traversable Par1 + +-- | @since 4.9.0.0 deriving instance Traversable f => Traversable (Rec1 f) + +-- | @since 4.9.0.0 deriving instance Traversable (K1 i c) + +-- | @since 4.9.0.0 deriving instance Traversable f => Traversable (M1 i c f) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :+: g) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :*: g) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :.: g) + +-- | @since 4.9.0.0 deriving instance Traversable UAddr + +-- | @since 4.9.0.0 deriving instance Traversable UChar + +-- | @since 4.9.0.0 deriving instance Traversable UDouble + +-- | @since 4.9.0.0 deriving instance Traversable UFloat + +-- | @since 4.9.0.0 deriving instance Traversable UInt + +-- | @since 4.9.0.0 deriving instance Traversable UWord + +-- Instance for Data.Ord +-- | @since 4.12.0.0 +deriving instance Traversable Down -- general functions diff --git a/Data/Type/Coercion.hs b/Data/Type/Coercion.hs --- a/Data/Type/Coercion.hs +++ b/Data/Type/Coercion.hs @@ -76,8 +76,13 @@ repr :: (a Eq.:~: b) -> Coercion a b repr Eq.Refl = Coercion +-- | @since 4.7.0.0 deriving instance Eq (Coercion a b) + +-- | @since 4.7.0.0 deriving instance Show (Coercion a b) + +-- | @since 4.7.0.0 deriving instance Ord (Coercion a b) -- | @since 4.7.0.0 diff --git a/Data/Type/Equality.hs b/Data/Type/Equality.hs --- a/Data/Type/Equality.hs +++ b/Data/Type/Equality.hs @@ -5,13 +5,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- @@ -120,8 +120,13 @@ outer :: (f a :~: g b) -> (f :~: g) outer Refl = Refl +-- | @since 4.7.0.0 deriving instance Eq (a :~: b) + +-- | @since 4.7.0.0 deriving instance Show (a :~: b) + +-- | @since 4.7.0.0 deriving instance Ord (a :~: b) -- | @since 4.7.0.0 diff --git a/Data/Typeable.hs b/Data/Typeable.hs --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -198,28 +198,30 @@ -- Keeping backwards-compatibility -typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep +typeOf1 :: forall t (a :: Type). Typeable t => t a -> TypeRep typeOf1 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep +typeOf2 :: forall t (a :: Type) (b :: Type). Typeable t => t a b -> TypeRep typeOf2 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t - => t a b c -> TypeRep +typeOf3 :: forall t (a :: Type) (b :: Type) (c :: Type). + Typeable t => t a b c -> TypeRep typeOf3 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t - => t a b c d -> TypeRep +typeOf4 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type). + Typeable t => t a b c d -> TypeRep typeOf4 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t - => t a b c d e -> TypeRep +typeOf5 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type). + Typeable t => t a b c d e -> TypeRep typeOf5 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *). - Typeable t => t a b c d e f -> TypeRep +typeOf6 :: forall t (a :: Type) (b :: Type) (c :: Type) + (d :: Type) (e :: Type) (f :: Type). + Typeable t => t a b c d e f -> TypeRep typeOf6 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *) - (g :: *). Typeable t => t a b c d e f g -> TypeRep +typeOf7 :: forall t (a :: Type) (b :: Type) (c :: Type) + (d :: Type) (e :: Type) (f :: Type) (g :: Type). + Typeable t => t a b c d e f g -> TypeRep typeOf7 _ = I.someTypeRep (Proxy :: Proxy t) diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs --- a/Data/Typeable/Internal.hs +++ b/Data/Typeable/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} @@ -85,7 +84,7 @@ import qualified GHC.Arr as A import GHC.Types ( TYPE ) import Data.Type.Equality -import GHC.List ( splitAt, foldl' ) +import GHC.List ( splitAt, foldl', elem ) import GHC.Word import GHC.Show import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol ) @@ -477,7 +476,7 @@ Refl -> IsCon con kinds -- | Use a 'TypeRep' as 'Typeable' evidence. -withTypeable :: forall (a :: k) (r :: TYPE rep). () +withTypeable :: forall k (a :: k) rep (r :: TYPE rep). () => TypeRep a -> (Typeable a => r) -> r withTypeable rep k = unsafeCoerce k' rep where k' :: Gift a r @@ -564,9 +563,17 @@ eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~~: b) eqTypeRep a b - | typeRepFingerprint a == typeRepFingerprint b = Just (unsafeCoerce HRefl) - | otherwise = Nothing + | sameTypeRep a b = Just (unsafeCoerce# HRefl) + | otherwise = Nothing +-- We want GHC to inline eqTypeRep to get rid of the Maybe +-- in the usual case that it is scrutinized immediately. We +-- split eqTypeRep into a worker and wrapper because otherwise +-- it's much larger than anything we'd want to inline. +{-# INLINABLE eqTypeRep #-} +sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2). + TypeRep a -> TypeRep b -> Bool +sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b ------------------------------------------------------------- -- @@ -624,7 +631,7 @@ unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x data SomeKindedTypeRep k where - SomeKindedTypeRep :: forall (a :: k). TypeRep a + SomeKindedTypeRep :: forall k (a :: k). TypeRep a -> SomeKindedTypeRep k kApp :: SomeKindedTypeRep (k -> k') @@ -633,7 +640,7 @@ kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) = SomeKindedTypeRep (mkTrApp f a) -kindedTypeRep :: forall (a :: k). Typeable a => SomeKindedTypeRep k +kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k kindedTypeRep = SomeKindedTypeRep (typeRep @a) buildList :: forall k. Typeable k @@ -769,11 +776,11 @@ | isTupleTyCon tc = showChar '(' . showArgs (showChar ',') tys . showChar ')' where (tc, tys) = splitApps rep -showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = []}) - = showsPrec p tycon +showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []}) + = showTyCon tycon showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args}) = showParen (p > 9) $ - showsPrec p tycon . + showTyCon tycon . showChar ' ' . showArgs (showChar ' ') args showTypeable p (TrFun {trFunArg = x, trFunRes = r}) @@ -833,6 +840,28 @@ | ('(':',':_) <- tyConName tc = True | otherwise = False +-- This is only an approximation. We don't have the general +-- character-classification machinery here, so we just do our best. +-- This should work for promoted Haskell 98 data constructors and +-- for TypeOperators type constructors that begin with ASCII +-- characters, but it will miss Unicode operators. +-- +-- If we wanted to catch Unicode as well, we ought to consider moving +-- GHC.Lexeme from ghc-boot-th to base. Then we could just say: +-- +-- startsVarSym symb || startsConSym symb +-- +-- But this is a fair deal of work just for one corner case, so I think I'll +-- leave it like this unless someone shouts. +isOperatorTyCon :: TyCon -> Bool +isOperatorTyCon tc + | symb : _ <- tyConName tc + , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True + | otherwise = False + +showTyCon :: TyCon -> ShowS +showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon) + showArgs :: Show a => ShowS -> [a] -> ShowS showArgs _ [] = id showArgs _ [a] = showsPrec 10 a @@ -951,7 +980,8 @@ tcNat = typeRepTyCon (typeRep @Nat) -- | An internal function, to make representations for type literals. -typeLitTypeRep :: forall (a :: k). (Typeable k) => String -> TyCon -> TypeRep a +typeLitTypeRep :: forall k (a :: k). (Typeable k) => + String -> TyCon -> TypeRep a typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) [] -- | For compiler use. diff --git a/Data/Version.hs b/Data/Version.hs --- a/Data/Version.hs +++ b/Data/Version.hs @@ -94,7 +94,10 @@ -- The interpretation of the list of tags is entirely dependent -- on the entity that this version applies to. } - deriving (Read,Show,Generic) + deriving ( Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + ) {-# DEPRECATED versionTags "See GHC ticket #2496" #-} -- TODO. Remove all references to versionTags in GHC 8.0 release. diff --git a/Foreign/C/Types.hs b/Foreign/C/Types.hs --- a/Foreign/C/Types.hs +++ b/Foreign/C/Types.hs @@ -68,7 +68,11 @@ -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable', -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating', - -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. + -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. That does mean + -- that `CFloat`'s (respectively `CDouble`'s) instances of + -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num' and + -- 'Prelude.Fractional' are as badly behaved as `Prelude.Float`'s + -- (respectively `Prelude.Double`'s). , CFloat(..), CDouble(..) -- XXX GHC doesn't support CLDouble yet -- , CLDouble(..) diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, + ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | @@ -79,20 +80,14 @@ -- no longer required. -- {-# INLINE malloc #-} -malloc :: Storable a => IO (Ptr a) -malloc = doMalloc undefined - where - doMalloc :: Storable b => b -> IO (Ptr b) - doMalloc dummy = mallocBytes (sizeOf dummy) +malloc :: forall a . Storable a => IO (Ptr a) +malloc = mallocBytes (sizeOf (undefined :: a)) -- |Like 'malloc' but memory is filled with bytes of value zero. -- {-# INLINE calloc #-} -calloc :: Storable a => IO (Ptr a) -calloc = doCalloc undefined - where - doCalloc :: Storable b => b -> IO (Ptr b) - doCalloc dummy = callocBytes (sizeOf dummy) +calloc :: forall a . Storable a => IO (Ptr a) +calloc = callocBytes (sizeOf (undefined :: a)) -- |Allocate a block of memory of the given number of bytes. -- The block of memory is sufficiently aligned for any of the basic @@ -117,12 +112,23 @@ -- exception), so the pointer passed to @f@ must /not/ be used after this. -- {-# INLINE alloca #-} -alloca :: Storable a => (Ptr a -> IO b) -> IO b -alloca = doAlloca undefined - where - doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' - doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) +alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b +alloca = + allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a)) +-- Note [NOINLINE for touch#] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously +-- fragile in the presence of simplification (see #14346). In particular, the +-- simplifier may drop the continuation containing the touch# if it can prove +-- that the action passed to allocaBytes will not return. The hack introduced to +-- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the +-- simplifier can't see the divergence. +-- +-- These can be removed once #14375 is fixed, which suggests that we instead do +-- away with touch# in favor of a primitive that will capture the scoping left +-- implicit in the case of touch#. + -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory of @n@ bytes. -- The block of memory is sufficiently aligned for any of the basic @@ -141,6 +147,8 @@ case touch# barr# s3 of { s4 -> (# s4, r #) }}}}} +-- See Note [NOINLINE for touch#] +{-# NOINLINE allocaBytes #-} allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> @@ -152,6 +160,8 @@ case touch# barr# s3 of { s4 -> (# s4, r #) }}}}} +-- See Note [NOINLINE for touch#] +{-# NOINLINE allocaBytesAligned #-} -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the size needed to store values of type @b@. The returned pointer @@ -163,14 +173,10 @@ -- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like -- 'malloc'. -- -realloc :: Storable b => Ptr a -> IO (Ptr b) -realloc = doRealloc undefined +realloc :: forall a b . Storable b => Ptr a -> IO (Ptr b) +realloc ptr = failWhenNULL "realloc" (_realloc ptr size) where - doRealloc :: Storable b' => b' -> Ptr a' -> IO (Ptr b') - doRealloc dummy ptr = let - size = fromIntegral (sizeOf dummy) - in - failWhenNULL "realloc" (_realloc ptr size) + size = fromIntegral (sizeOf (undefined :: b)) -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the given size. The returned pointer may refer to an entirely diff --git a/GHC/Arr.hs b/GHC/Arr.hs --- a/GHC/Arr.hs +++ b/GHC/Arr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RoleAnnotations #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -239,6 +240,15 @@ inRange (m,n) i = m <= i && i <= n ---------------------------------------------------------------------- +-- | @since 4.8.0.0 +instance Ix Natural where + range (m,n) = [m..n] + inRange (m,n) i = m <= i && i <= n + unsafeIndex (m,_) i = fromIntegral (i-m) + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Natural" + +---------------------------------------------------------------------- -- | @since 2.01 instance Ix Bool where -- as derived {-# INLINE range #-} @@ -505,8 +515,12 @@ -- | The value at the given index in an array. {-# INLINE (!) #-} (!) :: Ix i => Array i e -> i -> e -arr@(Array l u n _) ! i = unsafeAt arr $ safeIndex (l,u) n i +(!) arr@(Array l u n _) i = unsafeAt arr $ safeIndex (l,u) n i +{-# INLINE (!#) #-} +(!#) :: Ix i => Array i e -> i -> (# e #) +(!#) arr@(Array l u n _) i = unsafeAt# arr $ safeIndex (l,u) n i + {-# INLINE safeRangeSize #-} safeRangeSize :: Ix i => (i, i) -> Int safeRangeSize (l,u) = let r = rangeSize (l, u) @@ -550,6 +564,15 @@ unsafeAt (Array _ _ _ arr#) (I# i#) = case indexArray# arr# i# of (# e #) -> e +-- | Look up an element in an array without forcing it +unsafeAt# :: Array i e -> Int -> (# e #) +unsafeAt# (Array _ _ _ arr#) (I# i#) = indexArray# arr# i# + +-- | A convenient version of unsafeAt# +unsafeAtA :: Applicative f + => Array i e -> Int -> f e +unsafeAtA ary i = case unsafeAt# ary i of (# e #) -> pure e + -- | The bounds with which an array was constructed. {-# INLINE bounds #-} bounds :: Array i e -> (i,i) @@ -569,7 +592,7 @@ {-# INLINE elems #-} elems :: Array i e -> [e] elems arr@(Array _ _ n _) = - [unsafeAt arr i | i <- [0 .. n - 1]] + [e | i <- [0 .. n - 1], e <- unsafeAtA arr i] -- | A right fold over the elements {-# INLINABLE foldrElems #-} @@ -577,7 +600,8 @@ foldrElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == n = b0 - | otherwise = f (unsafeAt arr i) (go (i+1)) + | (# e #) <- unsafeAt# arr i + = f e (go (i+1)) in go 0 -- | A left fold over the elements @@ -586,7 +610,8 @@ foldlElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == (-1) = b0 - | otherwise = f (go (i-1)) (unsafeAt arr i) + | (# e #) <- unsafeAt# arr i + = f (go (i-1)) e in go (n-1) -- | A strict right fold over the elements @@ -595,7 +620,8 @@ foldrElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == (-1) = a - | otherwise = go (i-1) (f (unsafeAt arr i) $! a) + | (# e #) <- unsafeAt# arr i + = go (i-1) (f e $! a) in go (n-1) b0 -- | A strict left fold over the elements @@ -604,7 +630,8 @@ foldlElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == n = a - | otherwise = go (i+1) (a `seq` f a (unsafeAt arr i)) + | (# e #) <- unsafeAt# arr i + = go (i+1) (a `seq` f a e) in go 0 b0 -- | A left fold over the elements with no starting value @@ -613,7 +640,8 @@ foldl1Elems f = \ arr@(Array _ _ n _) -> let go i | i == 0 = unsafeAt arr 0 - | otherwise = f (go (i-1)) (unsafeAt arr i) + | (# e #) <- unsafeAt# arr i + = f (go (i-1)) e in if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1) @@ -623,7 +651,8 @@ foldr1Elems f = \ arr@(Array _ _ n _) -> let go i | i == n-1 = unsafeAt arr i - | otherwise = f (unsafeAt arr i) (go (i + 1)) + | (# e #) <- unsafeAt# arr i + = f e (go (i + 1)) in if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0 @@ -631,11 +660,12 @@ {-# INLINE assocs #-} assocs :: Ix i => Array i e -> [(i, e)] assocs arr@(Array l u _ _) = - [(i, arr ! i) | i <- range (l,u)] + [(i, e) | i <- range (l,u), let !(# e #) = arr !# i] -- | The 'accumArray' function deals with repeated indices in the association -- list using an /accumulating function/ which combines the values of -- associations with the same index. +-- -- For example, given a list of values of some index type, @hist@ -- produces a histogram of the number of occurrences of each index within -- a specified range: @@ -643,10 +673,10 @@ -- > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b -- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i] -- --- If the accumulating function is strict, then 'accumArray' is strict in --- the values, as well as the indices, in the association list. Thus, --- unlike ordinary arrays built with 'array', accumulated arrays should --- not in general be recursive. +-- @accumArray@ is strict in each result of applying the accumulating +-- function, although it is lazy in the initial value. Thus, unlike +-- arrays built with 'array', accumulated arrays should not in general +-- be recursive. {-# INLINE accumArray #-} accumArray :: Ix i => (e -> a -> e) -- ^ accumulating function @@ -667,7 +697,7 @@ unsafeAccumArray' :: (e -> a -> e) -> e -> (i,i) -> Int -> [(Int, a)] -> Array i e unsafeAccumArray' f initial (l,u) n@(I# n#) ies = runST (ST $ \s1# -> case newArray# n# initial s1# of { (# s2#, marr# #) -> - foldr (adjust f marr#) (done l u n marr#) ies s2# }) + foldr (adjust' f marr#) (done l u n marr#) ies s2# }) {-# INLINE adjust #-} adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b @@ -678,6 +708,18 @@ case writeArray# marr# i# (f old new) s2# of s3# -> next s3# +{-# INLINE adjust' #-} +adjust' :: (e -> a -> e) + -> MutableArray# s e + -> (Int, a) + -> STRep s b -> STRep s b +adjust' f marr# (I# i#, new) next + = \s1# -> case readArray# marr# i# s1# of + (# s2#, old #) -> + let !combined = f old new + in next (writeArray# marr# i# combined s2#) + + -- | Constructs an array identical to the first argument except that it has -- been updated by the associations in the right argument. -- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then @@ -706,6 +748,8 @@ -- -- > accumArray f z b = accum f (array b [(i, z) | i <- range b]) -- +-- @accum@ is strict in all the results of applying the accumulation. +-- However, it is lazy in the initial values of the array. {-# INLINE accum #-} accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e accum f arr@(Array l u n _) ies = @@ -715,7 +759,7 @@ unsafeAccum :: (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e unsafeAccum f arr ies = runST (do STArray l u n marr# <- thawSTArray arr - ST (foldr (adjust f marr#) (done l u n marr#) ies)) + ST (foldr (adjust' f marr#) (done l u n marr#) ies)) {-# INLINE [1] amap #-} -- See Note [amap] amap :: (a -> b) -> Array i a -> Array i b @@ -724,7 +768,8 @@ (# s2#, marr# #) -> let go i s# | i == n = done l u n marr# s# - | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s# + | (# e #) <- unsafeAt# arr i + = fill marr# (i, f e) (go (i+1)) s# in go 0 s2# ) {- Note [amap] diff --git a/GHC/Base.hs b/GHC/Base.hs --- a/GHC/Base.hs +++ b/GHC/Base.hs @@ -83,6 +83,9 @@ , UnboxedTuples , ExistentialQuantification , RankNTypes + , KindSignatures + , PolyKinds + , DataKinds #-} -- -Wno-orphans is needed for things like: -- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 @@ -114,7 +117,8 @@ module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, -- to avoid lots of people having to - module GHC.Err -- import it explicitly + module GHC.Err, -- import it explicitly + module GHC.Maybe ) where @@ -124,10 +128,12 @@ import GHC.Magic import GHC.Prim import GHC.Err +import GHC.Maybe import {-# SOURCE #-} GHC.IO (failIO,mplusIO) -import GHC.Tuple () -- Note [Depend on GHC.Tuple] -import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Tuple () -- Note [Depend on GHC.Tuple] +import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Natural () -- Note [Depend on GHC.Natural] -- for 'class Semigroup' import {-# SOURCE #-} GHC.Real (Integral) @@ -179,6 +185,10 @@ GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on GHC.Integer] --- to explain this to the build system. We make GHC.Base depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude. + +Note [Depend on GHC.Natural] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similar to GHC.Integer. -} #if 0 @@ -199,19 +209,6 @@ foldr = errorWithoutStackTrace "urk" #endif --- | The 'Maybe' type encapsulates an optional value. A value of type --- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), --- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to --- deal with errors or exceptional cases without resorting to drastic --- measures such as 'error'. --- --- The 'Maybe' type is also a monad. It is a simple kind of error --- monad, where all errors are represented by 'Nothing'. A richer --- error monad can be built using the 'Data.Either.Either' type. --- -data Maybe a = Nothing | Just a - deriving (Eq, Ord) - infixr 6 <> -- | The class of semigroups (types with an associative binary operation). @@ -595,6 +592,33 @@ -- | The 'join' function is the conventional monad join operator. It -- is used to remove one level of monadic structure, projecting its -- bound argument into the outer level. +-- +-- ==== __Examples__ +-- +-- A common use of 'join' is to run an 'IO' computation returned from +-- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions +-- can't perform 'IO' directly. Recall that +-- +-- @ +-- 'GHC.Conc.atomically' :: STM a -> IO a +-- @ +-- +-- is used to run 'GHC.Conc.STM' transactions atomically. So, by +-- specializing the types of 'GHC.Conc.atomically' and 'join' to +-- +-- @ +-- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b) +-- 'join' :: IO (IO b) -> IO b +-- @ +-- +-- we can compose them as +-- +-- @ +-- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b +-- @ +-- +-- to run an 'GHC.Conc.STM' transaction and the 'IO' action it +-- returns. join :: (Monad m) => m (m a) -> m a join x = x >>= id @@ -913,7 +937,9 @@ -- -- @since 4.9.0.0 data NonEmpty a = a :| [a] - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Functor NonEmpty where @@ -1287,16 +1313,20 @@ -- -- It is also useful in higher-order situations, such as @'map' ('$' 0) xs@, -- or @'Data.List.zipWith' ('$') fs xs@. +-- +-- Note that @($)@ is levity-polymorphic in its result type, so that +-- foo $ True where foo :: Bool -> Int# +-- is well-typed {-# INLINE ($) #-} -($) :: (a -> b) -> a -> b -f $ x = f x +($) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +f $ x = f x -- | Strict (call-by-value) application operator. It takes a function and an -- argument, evaluates the argument to weak head normal form (WHNF), then calls -- the function with that value. -($!) :: (a -> b) -> a -> b -f $! x = let !vx = x in f vx -- see #2273 +($!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +f $! x = let !vx = x in f vx -- see #2273 -- | @'until' p f@ yields the result of applying @f@ until @p@ holds. until :: (a -> Bool) -> (a -> a) -> a -> a diff --git a/GHC/Base.hs-boot b/GHC/Base.hs-boot --- a/GHC/Base.hs-boot +++ b/GHC/Base.hs-boot @@ -1,10 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module GHC.Base where +module GHC.Base (Maybe, Semigroup, Monoid) where +import GHC.Maybe (Maybe) import GHC.Types () class Semigroup a class Monoid a - -data Maybe a = Nothing | Just a diff --git a/GHC/ByteOrder.hs b/GHC/ByteOrder.hs --- a/GHC/ByteOrder.hs +++ b/GHC/ByteOrder.hs @@ -12,6 +12,7 @@ -- -- Target byte ordering. -- +-- @since 4.11.0.0 ----------------------------------------------------------------------------- module GHC.ByteOrder where @@ -20,7 +21,13 @@ data ByteOrder = BigEndian -- ^ most-significant-byte occurs in lowest address. | LittleEndian -- ^ least-significant-byte occurs in lowest address. - deriving (Eq, Ord, Bounded, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.11.0.0 + , Ord -- ^ @since 4.11.0.0 + , Bounded -- ^ @since 4.11.0.0 + , Enum -- ^ @since 4.11.0.0 + , Read -- ^ @since 4.11.0.0 + , Show -- ^ @since 4.11.0.0 + ) -- | The byte ordering of the target machine. targetByteOrder :: ByteOrder diff --git a/GHC/Conc.hs b/GHC/Conc.hs --- a/GHC/Conc.hs +++ b/GHC/Conc.hs @@ -74,8 +74,6 @@ , orElse , throwSTM , catchSTM - , alwaysSucceeds - , always , TVar(..) , newTVar , newTVarIO diff --git a/GHC/Conc/IO.hs b/GHC/Conc/IO.hs --- a/GHC/Conc/IO.hs +++ b/GHC/Conc/IO.hs @@ -188,8 +188,9 @@ case delay# time# s of { s' -> (# s', () #) }} --- | Set the value of returned TVar to True after a given number of --- microseconds. The caveats associated with threadDelay also apply. +-- | Switch the value of returned 'TVar' from initial value 'False' to 'True' +-- after a given number of microseconds. The caveats associated with +-- 'threadDelay' also apply. -- registerDelay :: Int -> IO (TVar Bool) registerDelay usecs diff --git a/GHC/Conc/Sync.hs b/GHC/Conc/Sync.hs --- a/GHC/Conc/Sync.hs +++ b/GHC/Conc/Sync.hs @@ -74,8 +74,6 @@ , orElse , throwSTM , catchSTM - , alwaysSucceeds - , always , TVar(..) , newTVar , newTVarIO @@ -105,6 +103,7 @@ import GHC.Base import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import GHC.Int import GHC.IO import GHC.IO.Encoding.UTF8 import GHC.IO.Exception @@ -194,18 +193,16 @@ -- -- @since 4.8.0.0 setAllocationCounter :: Int64 -> IO () -setAllocationCounter i = do - ThreadId t <- myThreadId - rts_setThreadAllocationCounter t i +setAllocationCounter (I64# i) = IO $ \s -> + case setThreadAllocationCounter# i s of s' -> (# s', () #) -- | Return the current value of the allocation counter for the -- current thread. -- -- @since 4.8.0.0 getAllocationCounter :: IO Int64 -getAllocationCounter = do - ThreadId t <- myThreadId - rts_getThreadAllocationCounter t +getAllocationCounter = IO $ \s -> + case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #) -- | Enables the allocation counter to be treated as a limit for the -- current thread. When the allocation limit is enabled, if the @@ -242,16 +239,6 @@ ThreadId t <- myThreadId rts_disableThreadAllocationLimit t --- We cannot do these operations safely on another thread, because on --- a 32-bit machine we cannot do atomic operations on a 64-bit value. --- Therefore, we only expose APIs that allow getting and setting the --- limit of the current thread. -foreign import ccall unsafe "rts_setThreadAllocationCounter" - rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO () - -foreign import ccall unsafe "rts_getThreadAllocationCounter" - rts_getThreadAllocationCounter :: ThreadId# -> IO Int64 - foreign import ccall unsafe "rts_enableThreadAllocationLimit" rts_enableThreadAllocationLimit :: ThreadId# -> IO () @@ -558,7 +545,10 @@ -- ^blocked on some other resource. Without @-threaded@, -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ -- they show up as 'BlockedOnMVar'. - deriving (Eq,Ord,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The current status of a thread data ThreadStatus @@ -570,7 +560,10 @@ -- ^the thread is blocked on some resource | ThreadDied -- ^the thread received an uncaught exception - deriving (Eq,Ord,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) threadStatus :: ThreadId -> IO ThreadStatus threadStatus (ThreadId t) = IO $ \s -> @@ -781,31 +774,6 @@ handler' e = case fromException e of Just e' -> unSTM (handler e') Nothing -> raiseIO# e - --- | Low-level primitive on which 'always' and 'alwaysSucceeds' are built. --- 'checkInv' differs from these in that, --- --- 1. the invariant is not checked when 'checkInv' is called, only at the end of --- this and subsequent transactions --- 2. the invariant failure is indicated by raising an exception. -checkInv :: STM a -> STM () -checkInv (STM m) = STM (\s -> case (check# m) s of s' -> (# s', () #)) - --- | 'alwaysSucceeds' adds a new invariant that must be true when passed --- to 'alwaysSucceeds', at the end of the current transaction, and at --- the end of every subsequent transaction. If it fails at any --- of those points then the transaction violating it is aborted --- and the exception raised by the invariant is propagated. -alwaysSucceeds :: STM a -> STM () -alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) - checkInv i - --- | 'always' is a variant of 'alwaysSucceeds' in which the invariant is --- expressed as an @STM Bool@ action that must return @True@. Returning --- @False@ or raising an exception are both treated as invariant failures. -always :: STM Bool -> STM () -always i = alwaysSucceeds ( do v <- i - if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) ) -- |Shared memory locations that support atomic memory transactions. data TVar a = TVar (TVar# RealWorld a) diff --git a/GHC/Conc/Windows.hs b/GHC/Conc/Windows.hs --- a/GHC/Conc/Windows.hs +++ b/GHC/Conc/Windows.hs @@ -278,7 +278,12 @@ -- these are sent to Services only. | Logoff | Shutdown - deriving (Eq, Ord, Enum, Show, Read) + deriving ( Eq -- ^ @since 4.3.0.0 + , Ord -- ^ @since 4.3.0.0 + , Enum -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + ) start_console_handler :: Word32 -> IO () start_console_handler r = diff --git a/GHC/Enum.hs b/GHC/Enum.hs --- a/GHC/Enum.hs +++ b/GHC/Enum.hs @@ -92,13 +92,51 @@ -- applied to a value that is too large to fit in an 'Int'. fromEnum :: a -> Int - -- | Used in Haskell's translation of @[n..]@. + -- | Used in Haskell's translation of @[n..]@ with @[n..] = enumFrom n@, + -- a possible implementation being @enumFrom n = n : enumFrom (succ n)@. + -- For example: + -- + -- * @enumFrom 4 :: [Integer] = [4,5,6,7,...]@ + -- * @enumFrom 6 :: [Int] = [6,7,8,9,...,maxBound :: Int]@ enumFrom :: a -> [a] - -- | Used in Haskell's translation of @[n,n'..]@. + -- | Used in Haskell's translation of @[n,n'..]@ + -- with @[n,n'..] = enumFromThen n n'@, a possible implementation being + -- @enumFromThen n n' = n : n' : worker (f x) (f x n')@, + -- @worker s v = v : worker s (s v)@, @x = fromEnum n' - fromEnum n@ and + -- @f n y + -- | n > 0 = f (n - 1) (succ y) + -- | n < 0 = f (n + 1) (pred y) + -- | otherwise = y@ + -- For example: + -- + -- * @enumFromThen 4 6 :: [Integer] = [4,6,8,10...]@ + -- * @enumFromThen 6 2 :: [Int] = [6,2,-2,-6,...,minBound :: Int]@ enumFromThen :: a -> a -> [a] - -- | Used in Haskell's translation of @[n..m]@. + -- | Used in Haskell's translation of @[n..m]@ with + -- @[n..m] = enumFromTo n m@, a possible implementation being + -- @enumFromTo n m + -- | n <= m = n : enumFromTo (succ n) m + -- | otherwise = []@. + -- For example: + -- + -- * @enumFromTo 6 10 :: [Int] = [6,7,8,9,10]@ + -- * @enumFromTo 42 1 :: [Integer] = []@ enumFromTo :: a -> a -> [a] - -- | Used in Haskell's translation of @[n,n'..m]@. + -- | Used in Haskell's translation of @[n,n'..m]@ with + -- @[n,n'..m] = enumFromThenTo n n' m@, a possible implementation + -- being @enumFromThenTo n n' m = worker (f x) (c x) n m@, + -- @x = fromEnum n' - fromEnum n@, @c x = bool (>=) (<=) (x > 0)@ + -- @f n y + -- | n > 0 = f (n - 1) (succ y) + -- | n < 0 = f (n + 1) (pred y) + -- | otherwise = y@ and + -- @worker s c v m + -- | c v m = v : worker s c (s v) m + -- | otherwise = []@ + -- For example: + -- + -- * @enumFromThenTo 4 2 -6 :: [Integer] = [4,2,0,-2,-4,-6]@ + -- * @enumFromThenTo 6 8 2 :: [Int] = []@ enumFromThenTo :: a -> a -> a -> [a] succ = toEnum . (+ 1) . fromEnum @@ -876,6 +914,79 @@ where go x | x < lim = [] | otherwise = x : go (x+delta) + +------------------------------------------------------------------------ +-- Natural +------------------------------------------------------------------------ + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Enum Natural where + succ n = n `plusNatural` wordToNaturalBase 1## + pred n = n `minusNatural` wordToNaturalBase 1## + + toEnum = intToNatural + + fromEnum (NatS# w) + | i >= 0 = i + | otherwise = errorWithoutStackTrace "fromEnum: out of Int range" + where + i = I# (word2Int# w) + fromEnum n = fromEnum (naturalToInteger n) + + enumFrom x = enumDeltaNatural x (wordToNaturalBase 1##) + enumFromThen x y + | x <= y = enumDeltaNatural x (y-x) + | otherwise = enumNegDeltaToNatural x (x-y) (wordToNaturalBase 0##) + + enumFromTo x lim = enumDeltaToNatural x (wordToNaturalBase 1##) lim + enumFromThenTo x y lim + | x <= y = enumDeltaToNatural x (y-x) lim + | otherwise = enumNegDeltaToNatural x (x-y) lim + +-- Helpers for 'Enum Natural'; TODO: optimise & make fusion work + +enumDeltaNatural :: Natural -> Natural -> [Natural] +enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d + +enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumDeltaToNatural x0 delta lim = go x0 + where + go x | x > lim = [] + | otherwise = x : go (x+delta) + +enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumNegDeltaToNatural x0 ndelta lim = go x0 + where + go x | x < lim = [] + | x >= ndelta = x : go (x-ndelta) + | otherwise = [x] + +#else + +-- | @since 4.8.0.0 +instance Enum Natural where + pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" + pred (Natural n) = Natural (pred n) + {-# INLINE pred #-} + succ (Natural n) = Natural (succ n) + {-# INLINE succ #-} + fromEnum (Natural n) = fromEnum n + {-# INLINE fromEnum #-} + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" + | otherwise = Natural (toEnum n) + {-# INLINE toEnum #-} + + enumFrom = coerce (enumFrom :: Integer -> [Integer]) + enumFromThen x y + | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y + | otherwise = enumFromThenTo x y (wordToNaturalBase 0##) + + enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) + enumFromThenTo + = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) + +#endif -- Instances from GHC.Types diff --git a/GHC/Err.hs b/GHC/Err.hs --- a/GHC/Err.hs +++ b/GHC/Err.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} -{-# LANGUAGE RankNTypes, TypeInType #-} +{-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -27,10 +27,12 @@ import GHC.Types (Char, RuntimeRep) import GHC.Stack.Types import GHC.Prim -import GHC.Integer () -- Make sure Integer is compiled first - -- because GHC depends on it in a wired-in way +import GHC.Integer () -- Make sure Integer and Natural are compiled first +import GHC.Natural () -- because GHC depends on it in a wired-in way -- so the build system doesn't see the dependency -import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) +import {-# SOURCE #-} GHC.Exception + ( errorCallWithCallStackException + , errorCallException ) -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). @@ -46,10 +48,7 @@ -- @since 4.9.0.0 errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r). [Char] -> a -errorWithoutStackTrace s = - -- we don't have withFrozenCallStack yet, so we just inline the definition - let ?callStack = freezeCallStack emptyCallStack - in error s +errorWithoutStackTrace s = raise# (errorCallException s) -- Note [Errors in base] diff --git a/GHC/Event/Control.hs b/GHC/Event/Control.hs --- a/GHC/Event/Control.hs +++ b/GHC/Event/Control.hs @@ -57,7 +57,9 @@ | CMsgDie | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Signal - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | The structure used to tell the IO manager thread what to do. data Control = W { diff --git a/GHC/Event/EPoll.hsc b/GHC/Event/EPoll.hsc --- a/GHC/Event/EPoll.hsc +++ b/GHC/Event/EPoll.hsc @@ -161,7 +161,12 @@ newtype EventType = EventType { unEventType :: Word32 - } deriving (Show, Eq, Num, Bits, FiniteBits) + } deriving ( Show -- ^ @since 4.4.0.0 + , Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Bits -- ^ @since 4.4.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + ) #{enum EventType, EventType , epollIn = EPOLLIN diff --git a/GHC/Event/Internal.hs b/GHC/Event/Internal.hs --- a/GHC/Event/Internal.hs +++ b/GHC/Event/Internal.hs @@ -40,7 +40,7 @@ -- | An I\/O event. newtype Event = Event Int - deriving (Eq) + deriving Eq -- ^ @since 4.4.0.0 evtNothing :: Event evtNothing = Event 0 @@ -64,7 +64,7 @@ eventIs :: Event -> Event -> Bool eventIs (Event a) (Event b) = a .&. b /= 0 --- | @since 4.3.1.0 +-- | @since 4.4.0.0 instance Show Event where show e = '[' : (intercalate "," . filter (not . null) $ [evtRead `so` "evtRead", @@ -78,7 +78,7 @@ (<>) = evtCombine stimes = stimesMonoid --- | @since 4.3.1.0 +-- | @since 4.4.0.0 instance Monoid Event where mempty = evtNothing mconcat = evtConcat @@ -97,7 +97,9 @@ data Lifetime = OneShot -- ^ the registration will be active for only one -- event | MultiShot -- ^ the registration will trigger multiple times - deriving (Show, Eq) + deriving ( Show -- ^ @since 4.8.1.0 + , Eq -- ^ @since 4.8.1.0 + ) -- | The longer of two lifetimes. elSupremum :: Lifetime -> Lifetime -> Lifetime @@ -121,7 +123,9 @@ -- Here we encode the event in the bottom three bits and the lifetime -- in the fourth bit. newtype EventLifetime = EL Int - deriving (Show, Eq) + deriving ( Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + ) -- | @since 4.11.0.0 instance Semigroup EventLifetime where @@ -149,7 +153,7 @@ -- | A type alias for timeouts, specified in nanoseconds. data Timeout = Timeout {-# UNPACK #-} !Word64 | Forever - deriving (Show) + deriving Show -- ^ @since 4.4.0.0 -- | Event notification backend. data Backend = forall a. Backend { diff --git a/GHC/Event/KQueue.hsc b/GHC/Event/KQueue.hsc --- a/GHC/Event/KQueue.hsc +++ b/GHC/Event/KQueue.hsc @@ -124,7 +124,9 @@ newtype KQueueFd = KQueueFd { fromKQueueFd :: CInt - } deriving (Eq, Show) + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) data Event = KEvent { ident :: {-# UNPACK #-} !CUIntPtr @@ -137,7 +139,7 @@ , data_ :: {-# UNPACK #-} !CIntPtr #endif , udata :: {-# UNPACK #-} !(Ptr ()) - } deriving Show + } deriving Show -- ^ @since 4.4.0.0 toEvents :: Fd -> [Filter] -> Flag -> FFlag -> [Event] toEvents fd flts flag fflag = map (\filt -> KEvent (fromIntegral fd) filt flag fflag 0 nullPtr) flts @@ -167,7 +169,10 @@ #{poke struct kevent, udata} ptr (udata ev) newtype FFlag = FFlag Word32 - deriving (Eq, Show, Storable) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) #{enum FFlag, FFlag , noteEOF = NOTE_EOF @@ -178,7 +183,13 @@ #else newtype Flag = Flag Word16 #endif - deriving (Bits, FiniteBits, Eq, Num, Show, Storable) + deriving ( Bits -- ^ @since 4.7.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + , Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) #{enum Flag, Flag , flagAdd = EV_ADD @@ -191,7 +202,11 @@ #else newtype Filter = Filter Int16 #endif - deriving (Eq, Num, Show, Storable) + deriving ( Eq -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + ) filterRead :: Filter filterRead = Filter (#const EVFILT_READ) diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs --- a/GHC/Event/Manager.hs +++ b/GHC/Event/Manager.hs @@ -110,7 +110,9 @@ data FdKey = FdKey { keyFd :: {-# UNPACK #-} !Fd , keyUnique :: {-# UNPACK #-} !Unique - } deriving (Eq, Show) + } deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | Callback invoked on I/O events. type IOCallback = FdKey -> Event -> IO () @@ -120,7 +122,9 @@ | Dying | Releasing | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) -- | The event manager state. data EventManager = EventManager diff --git a/GHC/Event/PSQ.hs b/GHC/Event/PSQ.hs --- a/GHC/Event/PSQ.hs +++ b/GHC/Event/PSQ.hs @@ -28,7 +28,7 @@ , singleton -- * Insertion - , insert + , unsafeInsertNew -- * Delete/Update , delete @@ -36,7 +36,6 @@ -- * Conversion , toList - , fromList -- * Min , findMin @@ -213,14 +212,7 @@ -- Insertion ------------------------------------------------------------------------------ --- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key --- is already present in the queue, the associated priority and value are --- replaced with the supplied priority and value. -insert :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v -insert k p x t0 = unsafeInsertNew k p x (delete k t0) - --- | Internal function to insert a key that is *not* present in the priority --- queue. +-- | /O(min(n,W))/ Insert a new key that is *not* present in the priority queue. {-# INLINABLE unsafeInsertNew #-} unsafeInsertNew :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v unsafeInsertNew k p x = go @@ -339,13 +331,6 @@ ------------------------------------------------------------------------------ -- Lists ------------------------------------------------------------------------------ - --- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples. --- If the list contains more than one priority and value for the same key, the --- last priority and value for the key is retained. -{-# INLINABLE fromList #-} -fromList :: [Elem v] -> IntPSQ v -fromList = foldr (\(E k p x) im -> insert k p x im) empty -- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The -- order of the list is not specified. diff --git a/GHC/Event/Poll.hsc b/GHC/Event/Poll.hsc --- a/GHC/Event/Poll.hsc +++ b/GHC/Event/Poll.hsc @@ -151,10 +151,16 @@ pfdFd :: {-# UNPACK #-} !Fd , pfdEvents :: {-# UNPACK #-} !Event , pfdRevents :: {-# UNPACK #-} !Event - } deriving (Show) + } deriving Show -- ^ @since 4.4.0.0 newtype Event = Event CShort - deriving (Eq, Show, Num, Storable, Bits, FiniteBits) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + , Storable -- ^ @since 4.4.0.0 + , Bits -- ^ @since 4.4.0.0 + , FiniteBits -- ^ @since 4.7.0.0 + ) -- We have to duplicate the whole enum like this in order for the -- hsc2hs cross-compilation mode to work diff --git a/GHC/Event/TimerManager.hs b/GHC/Event/TimerManager.hs --- a/GHC/Event/TimerManager.hs +++ b/GHC/Event/TimerManager.hs @@ -45,8 +45,9 @@ import GHC.Base import GHC.Clock (getMonotonicTimeNSec) import GHC.Conc.Signal (runHandlers) +import GHC.Enum (maxBound) import GHC.Num (Num(..)) -import GHC.Real (fromIntegral) +import GHC.Real (quot, fromIntegral) import GHC.Show (Show(..)) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) @@ -67,7 +68,7 @@ -- | A timeout registration cookie. newtype TimeoutKey = TK Unique - deriving (Eq) + deriving Eq -- ^ @since 4.7.0.0 -- | Callback invoked on timeout events. type TimeoutCallback = IO () @@ -76,7 +77,9 @@ | Running | Dying | Finished - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + ) -- | A priority search queue, with timeouts as priorities. type TimeoutQueue = Q.PSQ TimeoutCallback @@ -206,6 +209,18 @@ ------------------------------------------------------------------------ -- Registering interest in timeout events +expirationTime :: Int -> IO Q.Prio +expirationTime us = do + now <- getMonotonicTimeNSec + let expTime + -- Currently we treat overflows by clamping to maxBound. If humanity + -- still exists in 2500 CE we will ned to be a bit more careful here. + -- See #15158. + | (maxBound - now) `quot` 1000 < fromIntegral us = maxBound + | otherwise = now + ns + where ns = 1000 * fromIntegral us + return expTime + -- | Register a timeout in the given number of microseconds. The -- returned 'TimeoutKey' can be used to later unregister or update the -- timeout. The timeout is automatically unregistered after the given @@ -215,10 +230,11 @@ !key <- newUnique (emUniqueSource mgr) if us <= 0 then cb else do - now <- getMonotonicTimeNSec - let expTime = fromIntegral us * 1000 + now + expTime <- expirationTime us - editTimeouts mgr (Q.insert key expTime cb) + -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It + -- doesn't because we just generated it from a unique supply. + editTimeouts mgr (Q.unsafeInsertNew key expTime cb) return $ TK key -- | Unregister an active timeout. @@ -230,9 +246,7 @@ -- microseconds. updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO () updateTimeout mgr (TK key) us = do - now <- getMonotonicTimeNSec - let expTime = fromIntegral us * 1000 + now - + expTime <- expirationTime us editTimeouts mgr (Q.adjust (const expTime) key) editTimeouts :: TimerManager -> TimeoutEdit -> IO () diff --git a/GHC/Event/Unique.hs b/GHC/Event/Unique.hs --- a/GHC/Event/Unique.hs +++ b/GHC/Event/Unique.hs @@ -19,7 +19,10 @@ data UniqueSource = US (MutableByteArray# RealWorld) newtype Unique = Unique { asInt :: Int } - deriving (Eq, Ord, Num) + deriving ( Eq -- ^ @since 4.4.0.0 + , Ord -- ^ @since 4.4.0.0 + , Num -- ^ @since 4.4.0.0 + ) -- | @since 4.3.1.0 instance Show Unique where diff --git a/GHC/Exception.hs b/GHC/Exception.hs --- a/GHC/Exception.hs +++ b/GHC/Exception.hs @@ -5,6 +5,7 @@ , RecordWildCards , PatternSynonyms #-} +{-# LANGUAGE TypeInType #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -22,155 +23,38 @@ ----------------------------------------------------------------------------- module GHC.Exception - ( Exception(..) -- Class + ( module GHC.Exception.Type , throw - , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) - , divZeroException, overflowException, ratioZeroDenomException - , underflowException - , errorCallException, errorCallWithCallStackException + , ErrorCall(..,ErrorCall) + , errorCallException + , errorCallWithCallStackException -- re-export CallStack and SrcLoc from GHC.Types , CallStack, fromCallSiteList, getCallStack, prettyCallStack , prettyCallStackLines, showCCSStack , SrcLoc(..), prettySrcLoc ) where -import Data.Maybe -import Data.Typeable (Typeable, cast) - -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show import GHC.Stack.Types import GHC.OldList +import GHC.Prim import GHC.IO.Unsafe import {-# SOURCE #-} GHC.Stack.CCS - -{- | -The @SomeException@ type is the root of the exception type hierarchy. -When an exception of type @e@ is thrown, behind the scenes it is -encapsulated in a @SomeException@. --} -data SomeException = forall e . Exception e => SomeException e - --- | @since 3.0 -instance Show SomeException where - showsPrec p (SomeException e) = showsPrec p e - -{- | -Any type that you wish to throw or catch as an exception must be an -instance of the @Exception@ class. The simplest case is a new exception -type directly below the root: - -> data MyException = ThisException | ThatException -> deriving Show -> -> instance Exception MyException - -The default method definitions in the @Exception@ class do what we need -in this case. You can now throw and catch @ThisException@ and -@ThatException@ as exceptions: - -@ -*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) -Caught ThisException -@ - -In more complicated examples, you may wish to define a whole hierarchy -of exceptions: - -> --------------------------------------------------------------------- -> -- Make the root exception type for all the exceptions in a compiler -> -> data SomeCompilerException = forall e . Exception e => SomeCompilerException e -> -> instance Show SomeCompilerException where -> show (SomeCompilerException e) = show e -> -> instance Exception SomeCompilerException -> -> compilerExceptionToException :: Exception e => e -> SomeException -> compilerExceptionToException = toException . SomeCompilerException -> -> compilerExceptionFromException :: Exception e => SomeException -> Maybe e -> compilerExceptionFromException x = do -> SomeCompilerException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make a subhierarchy for exceptions in the frontend of the compiler -> -> data SomeFrontendException = forall e . Exception e => SomeFrontendException e -> -> instance Show SomeFrontendException where -> show (SomeFrontendException e) = show e -> -> instance Exception SomeFrontendException where -> toException = compilerExceptionToException -> fromException = compilerExceptionFromException -> -> frontendExceptionToException :: Exception e => e -> SomeException -> frontendExceptionToException = toException . SomeFrontendException -> -> frontendExceptionFromException :: Exception e => SomeException -> Maybe e -> frontendExceptionFromException x = do -> SomeFrontendException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make an exception type for a particular frontend compiler exception -> -> data MismatchedParentheses = MismatchedParentheses -> deriving Show -> -> instance Exception MismatchedParentheses where -> toException = frontendExceptionToException -> fromException = frontendExceptionFromException - -We can now catch a @MismatchedParentheses@ exception as -@MismatchedParentheses@, @SomeFrontendException@ or -@SomeCompilerException@, but not other types, e.g. @IOException@: - -@ -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) -*** Exception: MismatchedParentheses -@ - --} -class (Typeable e, Show e) => Exception e where - toException :: e -> SomeException - fromException :: SomeException -> Maybe e - - toException = SomeException - fromException (SomeException e) = cast e - - -- | Render this exception value in a human-friendly manner. - -- - -- Default implementation: @'show'@. - -- - -- @since 4.8.0.0 - displayException :: e -> String - displayException = show - --- | @since 3.0 -instance Exception SomeException where - toException se = se - fromException = Just - displayException (SomeException e) = displayException e +import GHC.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely -- functional code, but may only be caught within the 'IO' monad. -throw :: Exception e => e -> a +throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e. + Exception e => e -> a throw e = raise# (toException e) -- | This is thrown when the user calls 'error'. The first @String@ is the -- argument given to 'error', second @String@ is the location. data ErrorCall = ErrorCallWithLocation String String - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + ) pattern ErrorCall :: String -> ErrorCall pattern ErrorCall err <- ErrorCallWithLocation err _ where @@ -184,7 +68,8 @@ -- | @since 4.0.0.0 instance Show ErrorCall where showsPrec _ (ErrorCallWithLocation err "") = showString err - showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc) + showsPrec _ (ErrorCallWithLocation err loc) = + showString err . showChar '\n' . showString loc errorCallException :: String -> SomeException errorCallException s = toException (ErrorCall s) @@ -230,31 +115,3 @@ : map ((" " ++) . prettyCallSite) stk where prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc - --- |Arithmetic exceptions. -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - | RatioZeroDenominator -- ^ @since 4.6.0.0 - deriving (Eq, Ord) - -divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException -divZeroException = toException DivideByZero -overflowException = toException Overflow -ratioZeroDenomException = toException RatioZeroDenominator -underflowException = toException Underflow - --- | @since 4.0.0.0 -instance Exception ArithException - --- | @since 4.0.0.0 -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" - showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/GHC/Exception.hs-boot b/GHC/Exception.hs-boot --- a/GHC/Exception.hs-boot +++ b/GHC/Exception.hs-boot @@ -24,17 +24,15 @@ to get a visibly-bottom value. -} -module GHC.Exception ( SomeException, errorCallException, - errorCallWithCallStackException, - divZeroException, overflowException, ratioZeroDenomException, - underflowException - ) where +module GHC.Exception + ( module GHC.Exception.Type + , errorCallException + , errorCallWithCallStackException + ) where + +import {-# SOURCE #-} GHC.Exception.Type import GHC.Types ( Char ) import GHC.Stack.Types ( CallStack ) - -data SomeException -divZeroException, overflowException, ratioZeroDenomException :: SomeException -underflowException :: SomeException errorCallException :: [Char] -> SomeException errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/GHC/Exception/Type.hs b/GHC/Exception/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Exception/Type.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , RecordWildCards + , PatternSynonyms + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception.Type +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +----------------------------------------------------------------------------- + +module GHC.Exception.Type + ( Exception(..) -- Class + , SomeException(..), ArithException(..) + , divZeroException, overflowException, ratioZeroDenomException + , underflowException + ) where + +import Data.Maybe +import Data.Typeable (Typeable, cast) + -- loop: Data.Typeable -> GHC.Err -> GHC.Exception +import GHC.Base +import GHC.Show + +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} +data SomeException = forall e . Exception e => SomeException e + +-- | @since 3.0 +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving Show +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving Show +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + + -- | Render this exception value in a human-friendly manner. + -- + -- Default implementation: @'show'@. + -- + -- @since 4.8.0.0 + displayException :: e -> String + displayException = show + +-- | @since 3.0 +instance Exception SomeException where + toException se = se + fromException = Just + displayException (SomeException e) = displayException e + +-- |Arithmetic exceptions. +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + | RatioZeroDenominator -- ^ @since 4.6.0.0 + deriving ( Eq -- ^ @since 3.0 + , Ord -- ^ @since 3.0 + ) + +divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException +divZeroException = toException DivideByZero +overflowException = toException Overflow +ratioZeroDenomException = toException RatioZeroDenominator +underflowException = toException Underflow + +-- | @since 4.0.0.0 +instance Exception ArithException + +-- | @since 4.0.0.0 +instance Show ArithException where + showsPrec _ Overflow = showString "arithmetic overflow" + showsPrec _ Underflow = showString "arithmetic underflow" + showsPrec _ LossOfPrecision = showString "loss of precision" + showsPrec _ DivideByZero = showString "divide by zero" + showsPrec _ Denormal = showString "denormal" + showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/GHC/Exception/Type.hs-boot b/GHC/Exception/Type.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Exception/Type.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Exception.Type + ( SomeException + , divZeroException + , overflowException + , ratioZeroDenomException + , underflowException + ) where + +import GHC.Types () + +data SomeException +divZeroException, overflowException, + ratioZeroDenomException, underflowException :: SomeException diff --git a/GHC/Exts.hs b/GHC/Exts.hs --- a/GHC/Exts.hs +++ b/GHC/Exts.hs @@ -154,7 +154,9 @@ -- entire ghc package at runtime data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr - deriving( Data, Eq ) + deriving ( Data -- ^ @since 4.3.0.0 + , Eq -- ^ @since 4.3.0.0 + ) {- ********************************************************************** diff --git a/GHC/Fingerprint/Type.hs b/GHC/Fingerprint/Type.hs --- a/GHC/Fingerprint/Type.hs +++ b/GHC/Fingerprint/Type.hs @@ -22,7 +22,9 @@ -- Using 128-bit MD5 fingerprints for now. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.4.0.0 + , Ord -- ^ @since 4.4.0.0 + ) -- | @since 4.7.0.0 instance Show Fingerprint where diff --git a/GHC/Float.hs b/GHC/Float.hs --- a/GHC/Float.hs +++ b/GHC/Float.hs @@ -64,6 +64,13 @@ ------------------------------------------------------------------------ -- | Trigonometric and hyperbolic functions and related functions. +-- +-- The Haskell Report defines no laws for 'Floating'. However, '(+)', '(*)' +-- and 'exp' are customarily expected to define an exponential field and have +-- the following properties: +-- +-- * @exp (a + b)@ = @exp a * exp b +-- * @exp (fromInteger 0)@ = @fromInteger 1@ class (Fractional a) => Floating a where pi :: a exp, log, sqrt :: a -> a @@ -245,7 +252,18 @@ ------------------------------------------------------------------------ -- | @since 2.01 -instance Num Float where +-- Note that due to the presence of @NaN@, not all elements of 'Float' have an +-- additive inverse. +-- +-- >>> 0/0 + (negate 0/0 :: Float) +-- NaN +-- +-- Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't +-- have an additive identity +-- +-- >>> 0 + (-0 :: Float) +-- 0.0 +instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y negate x = negateFloat x @@ -272,6 +290,11 @@ smallInteger m# :% shiftLInteger 1 (negateInt# e#) -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Float' have an +-- multiplicative inverse. +-- +-- >>> 0/0 * (recip 0/0 :: Float) +-- NaN instance Fractional Float where (/) x y = divideFloat x y {-# INLINE fromRational #-} @@ -367,7 +390,11 @@ (**) x y = powerFloat x y logBase x y = log y / log x - asinh x = log (x + sqrt (1.0+x*x)) + asinh x + | x > huge = log 2 + log x + | x < 0 = -asinh (-x) + | otherwise = log (x + sqrt (1 + x*x)) + where huge = 1e10 acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) atanh x = 0.5 * log ((1.0+x) / (1.0-x)) @@ -425,6 +452,17 @@ ------------------------------------------------------------------------ -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Double' have an +-- additive inverse. +-- +-- >>> 0/0 + (negate 0/0 :: Double) +-- NaN +-- +-- Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't +-- have an additive identity +-- +-- >>> 0 + (-0 :: Double) +-- 0.0 instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y @@ -454,6 +492,11 @@ m :% shiftLInteger 1 (negateInt# e#) -- | @since 2.01 +-- Note that due to the presence of @NaN@, not all elements of 'Double' have an +-- multiplicative inverse. +-- +-- >>> 0/0 * (recip 0/0 :: Double) +-- NaN instance Fractional Double where (/) x y = divideDouble x y {-# INLINE fromRational #-} @@ -492,7 +535,11 @@ (**) x y = powerDouble x y logBase x y = log y / log x - asinh x = log (x + sqrt (1.0+x*x)) + asinh x + | x > huge = log 2 + log x + | x < 0 = -asinh (-x) + | otherwise = log (x + sqrt (1 + x*x)) + where huge = 1e20 acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) atanh x = 0.5 * log ((1.0+x) / (1.0-x)) @@ -682,6 +729,18 @@ [d] -> d : ".0e" ++ show_e' (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' [] -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []" + Just d | d <= 0 -> + -- handle this case specifically since we need to omit the + -- decimal point as well (#15115). + -- Note that this handles negative precisions as well for consistency + -- (see #15509). + case is of + [0] -> "0e0" + _ -> + let + (ei,is') = roundTo base 1 is + n:_ = map intToDigit (if ei > 0 then init is' else is') + in n : 'e' : show (e-1+ei) Just dec -> let dec' = max dec 1 in case is of diff --git a/GHC/Generics.hs b/GHC/Generics.hs --- a/GHC/Generics.hs +++ b/GHC/Generics.hs @@ -15,7 +15,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -732,6 +731,7 @@ -- We use some base types import Data.Either ( Either (..) ) import Data.Maybe ( Maybe(..), fromMaybe ) +import Data.Ord ( Down(..) ) import GHC.Integer ( Integer, integerToInt ) import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) @@ -740,7 +740,8 @@ -- Needed for instances import GHC.Arr ( Ix ) import GHC.Base ( Alternative(..), Applicative(..), Functor(..) - , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce ) + , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce + , Semigroup(..), Monoid(..) ) import GHC.Classes ( Eq(..), Ord(..) ) import GHC.Enum ( Bounded, Enum ) import GHC.Read ( Read(..) ) @@ -765,15 +766,21 @@ , Generic1 -- ^ @since 4.9.0.0 ) +-- | @since 4.12.0.0 +instance Semigroup (V1 p) where + v <> _ = v + -- | Unit: used for constructors without arguments data U1 (p :: k) = U1 - deriving (Generic, Generic1) + deriving ( Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Eq (U1 p) where _ == _ = True --- | @since 4.9.0.0 +-- | @since 4.7.0.0 instance Ord (U1 p) where compare _ _ = EQ @@ -806,9 +813,24 @@ -- | @since 4.9.0.0 instance MonadPlus U1 +-- | @since 4.12.0.0 +instance Semigroup (U1 p) where + _ <> _ = U1 + +-- | @since 4.12.0.0 +instance Monoid (U1 p) where + mempty = U1 + -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Applicative Par1 where @@ -820,10 +842,23 @@ instance Monad Par1 where Par1 x >>= f = f x +-- | @since 4.12.0.0 +deriving instance Semigroup p => Semigroup (Par1 p) + +-- | @since 4.12.0.0 +deriving instance Monoid p => Monoid (Par1 p) + -- | Recursive calls of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@ -- is enabled) -newtype Rec1 (f :: k -> *) (p :: k) = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype Rec1 (f :: k -> Type) (p :: k) = Rec1 { unRec1 :: f p } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 deriving instance Applicative f => Applicative (Rec1 f) @@ -838,10 +873,35 @@ -- | @since 4.9.0.0 deriving instance MonadPlus f => MonadPlus (Rec1 f) +-- | @since 4.12.0.0 +deriving instance Semigroup (f p) => Semigroup (Rec1 f p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f p) => Monoid (Rec1 f p) + -- | Constants, additional parameters and recursion of kind @*@ -newtype K1 (i :: *) c (p :: k) = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype K1 (i :: Type) c (p :: k) = K1 { unK1 :: c } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) +-- | @since 4.12.0.0 +instance Monoid c => Applicative (K1 i c) where + pure _ = K1 mempty + liftA2 = \_ -> coerce (mappend :: c -> c -> c) + (<*>) = coerce (mappend :: c -> c -> c) + +-- | @since 4.12.0.0 +deriving instance Semigroup c => Semigroup (K1 i c p) + +-- | @since 4.12.0.0 +deriving instance Monoid c => Monoid (K1 i c p) + -- | @since 4.9.0.0 deriving instance Applicative f => Applicative (M1 i c f) @@ -854,19 +914,47 @@ -- | @since 4.9.0.0 deriving instance MonadPlus f => MonadPlus (M1 i c f) +-- | @since 4.12.0.0 +deriving instance Semigroup (f p) => Semigroup (M1 i c f p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f p) => Monoid (M1 i c f p) + -- | Meta-information (constructor names, etc.) -newtype M1 (i :: *) (c :: Meta) (f :: k -> *) (p :: k) = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +newtype M1 (i :: Type) (c :: Meta) (f :: k -> Type) (p :: k) = + M1 { unM1 :: f p } + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Sums: encode choice between constructors infixr 5 :+: -data (:+:) (f :: k -> *) (g :: k -> *) (p :: k) = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +data (:+:) (f :: k -> Type) (g :: k -> Type) (p :: k) = L1 (f p) | R1 (g p) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Products: encode multiple arguments to constructors infixr 6 :*: -data (:*:) (f :: k -> *) (g :: k -> *) (p :: k) = f p :*: g p - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +data (:*:) (f :: k -> Type) (g :: k -> Type) (p :: k) = f p :*: g p + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Applicative f, Applicative g) => Applicative (f :*: g) where @@ -889,11 +977,26 @@ -- | @since 4.9.0.0 instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) +-- | @since 4.12.0.0 +instance (Semigroup (f p), Semigroup (g p)) => Semigroup ((f :*: g) p) where + (x1 :*: y1) <> (x2 :*: y2) = (x1 <> x2) :*: (y1 <> y2) + +-- | @since 4.12.0.0 +instance (Monoid (f p), Monoid (g p)) => Monoid ((f :*: g) p) where + mempty = mempty :*: mempty + -- | Composition of functors infixr 7 :.: -newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = +newtype (:.:) (f :: k2 -> Type) (g :: k1 -> k2) (p :: k1) = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.7.0.0 + , Ord -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Show -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Applicative f, Applicative g) => Applicative (f :.: g) where @@ -907,46 +1010,85 @@ (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) :: forall a . (f :.: g) a -> (f :.: g) a -> (f :.: g) a +-- | @since 4.12.0.0 +deriving instance Semigroup (f (g p)) => Semigroup ((f :.: g) p) + +-- | @since 4.12.0.0 +deriving instance Monoid (f (g p)) => Monoid ((f :.: g) p) + -- | Constants of unlifted kinds -- -- @since 4.9.0.0 -data family URec (a :: *) (p :: k) +data family URec (a :: Type) (p :: k) -- | Used for marking occurrences of 'Addr#' -- -- @since 4.9.0.0 data instance URec (Ptr ()) (p :: k) = UAddr { uAddr# :: Addr# } - deriving (Eq, Ord, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Char#' -- -- @since 4.9.0.0 data instance URec Char (p :: k) = UChar { uChar# :: Char# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Double#' -- -- @since 4.9.0.0 data instance URec Double (p :: k) = UDouble { uDouble# :: Double# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Float#' -- -- @since 4.9.0.0 data instance URec Float (p :: k) = UFloat { uFloat# :: Float# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq, Ord, Show + , Functor -- ^ @since 4.9.0.0 + , Generic + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Int#' -- -- @since 4.9.0.0 data instance URec Int (p :: k) = UInt { uInt# :: Int# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Used for marking occurrences of 'Word#' -- -- @since 4.9.0.0 data instance URec Word (p :: k) = UWord { uWord# :: Word# } - deriving (Eq, Ord, Show, Functor, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | Type synonym for @'URec' 'Addr#'@ -- @@ -977,10 +1119,10 @@ -- @since 4.9.0.0 type UWord = URec Word --- | Tag for K1: recursion (of kind @*@) +-- | Tag for K1: recursion (of kind @Type@) data R --- | Type synonym for encoding recursion (of kind @*@) +-- | Type synonym for encoding recursion (of kind @Type@) type Rec0 = K1 R -- | Tag for M1: datatype @@ -1002,17 +1144,17 @@ -- | Class for datatypes that represent datatypes class Datatype d where -- | The name of the datatype (unqualified) - datatypeName :: t d (f :: k -> *) (a :: k) -> [Char] + datatypeName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | The fully-qualified name of the module where the type is declared - moduleName :: t d (f :: k -> *) (a :: k) -> [Char] + moduleName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | The package name of the module where the type is declared -- -- @since 4.9.0.0 - packageName :: t d (f :: k -> *) (a :: k) -> [Char] + packageName :: t d (f :: k -> Type) (a :: k) -> [Char] -- | Marks if the datatype is actually a newtype -- -- @since 4.7.0.0 - isNewtype :: t d (f :: k -> *) (a :: k) -> Bool + isNewtype :: t d (f :: k -> Type) (a :: k) -> Bool isNewtype _ = False -- | @since 4.9.0.0 @@ -1026,14 +1168,14 @@ -- | Class for datatypes that represent data constructors class Constructor c where -- | The name of the constructor - conName :: t c (f :: k -> *) (a :: k) -> [Char] + conName :: t c (f :: k -> Type) (a :: k) -> [Char] -- | The fixity of the constructor - conFixity :: t c (f :: k -> *) (a :: k) -> Fixity + conFixity :: t c (f :: k -> Type) (a :: k) -> Fixity conFixity _ = Prefix -- | Marks if this constructor is a record - conIsRecord :: t c (f :: k -> *) (a :: k) -> Bool + conIsRecord :: t c (f :: k -> Type) (a :: k) -> Bool conIsRecord _ = False -- | @since 4.9.0.0 @@ -1046,7 +1188,12 @@ -- | Datatype to represent the fixity of a constructor. An infix -- | declaration directly corresponds to an application of 'Infix'. data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read, Generic) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + , Ord -- ^ @since 4.6.0.0 + , Read -- ^ @since 4.6.0.0 + , Generic -- ^ @since 4.7.0.0 + ) -- | This variant of 'Fixity' appears at the type level. -- @@ -1062,7 +1209,15 @@ data Associativity = LeftAssociative | RightAssociative | NotAssociative - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + , Ord -- ^ @since 4.6.0.0 + , Read -- ^ @since 4.6.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.7.0.0 + ) -- | The unpackedness of a field as the user wrote it in the source code. For -- example, in the following data type: @@ -1080,7 +1235,15 @@ data SourceUnpackedness = NoSourceUnpackedness | SourceNoUnpack | SourceUnpack - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | The strictness of a field as the user wrote it in the source code. For -- example, in the following data type: @@ -1096,7 +1259,15 @@ data SourceStrictness = NoSourceStrictness | SourceLazy | SourceStrict - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | The strictness that GHC infers for a field during compilation. Whereas -- there are nine different combinations of 'SourceUnpackedness' and @@ -1123,24 +1294,32 @@ data DecidedStrictness = DecidedLazy | DecidedStrict | DecidedUnpack - deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + deriving ( Eq -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + ) -- | Class for datatypes that represent records class Selector s where -- | The name of the selector - selName :: t s (f :: k -> *) (a :: k) -> [Char] + selName :: t s (f :: k -> Type) (a :: k) -> [Char] -- | The selector's unpackedness annotation (if any) -- -- @since 4.9.0.0 - selSourceUnpackedness :: t s (f :: k -> *) (a :: k) -> SourceUnpackedness + selSourceUnpackedness :: t s (f :: k -> Type) (a :: k) -> SourceUnpackedness -- | The selector's strictness annotation (if any) -- -- @since 4.9.0.0 - selSourceStrictness :: t s (f :: k -> *) (a :: k) -> SourceStrictness + selSourceStrictness :: t s (f :: k -> Type) (a :: k) -> SourceStrictness -- | The strictness that the compiler inferred for the selector -- -- @since 4.9.0.0 - selDecidedStrictness :: t s (f :: k -> *) (a :: k) -> DecidedStrictness + selDecidedStrictness :: t s (f :: k -> Type) (a :: k) -> DecidedStrictness -- | @since 4.9.0.0 instance (SingI mn, SingI su, SingI ss, SingI ds) @@ -1161,7 +1340,7 @@ -- @ class Generic a where -- | Generic representation type - type Rep a :: * -> * + type Rep a :: Type -> Type -- | Convert from the datatype to its representation from :: a -> (Rep a) x -- | Convert from the representation to the datatype @@ -1178,9 +1357,9 @@ -- 'from1' . 'to1' ≡ 'id' -- 'to1' . 'from1' ≡ 'id' -- @ -class Generic1 (f :: k -> *) where +class Generic1 (f :: k -> Type) where -- | Generic representation type - type Rep1 f :: k -> * + type Rep1 f :: k -> Type -- | Convert from the datatype to its representation from1 :: f a -> (Rep1 f) a -- | Convert from the representation to the datatype @@ -1215,33 +1394,88 @@ -- Derived instances -------------------------------------------------------------------------------- +-- | @since 4.6.0.0 deriving instance Generic [a] + +-- | @since 4.6.0.0 deriving instance Generic (NonEmpty a) + +-- | @since 4.6.0.0 deriving instance Generic (Maybe a) + +-- | @since 4.6.0.0 deriving instance Generic (Either a b) + +-- | @since 4.6.0.0 deriving instance Generic Bool + +-- | @since 4.6.0.0 deriving instance Generic Ordering + +-- | @since 4.6.0.0 deriving instance Generic (Proxy t) + +-- | @since 4.6.0.0 deriving instance Generic () + +-- | @since 4.6.0.0 deriving instance Generic ((,) a b) + +-- | @since 4.6.0.0 deriving instance Generic ((,,) a b c) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,) a b c d) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,) a b c d e) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,,) a b c d e f) + +-- | @since 4.6.0.0 deriving instance Generic ((,,,,,,) a b c d e f g) +-- | @since 4.12.0.0 +deriving instance Generic (Down a) + + +-- | @since 4.6.0.0 deriving instance Generic1 [] + +-- | @since 4.6.0.0 deriving instance Generic1 NonEmpty + +-- | @since 4.6.0.0 deriving instance Generic1 Maybe + +-- | @since 4.6.0.0 deriving instance Generic1 (Either a) + +-- | @since 4.6.0.0 deriving instance Generic1 Proxy + +-- | @since 4.6.0.0 deriving instance Generic1 ((,) a) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,) a b) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,) a b c) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,) a b c d) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,) a b c d e) + +-- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,,) a b c d e f) +-- | @since 4.12.0.0 +deriving instance Generic1 Down + -------------------------------------------------------------------------------- -- Copied from the singletons package -------------------------------------------------------------------------------- @@ -1263,7 +1497,7 @@ class SingKind k where -- | Get a base type from a proxy for the promoted kind. For example, -- @DemoteRep Bool@ will be the type @Bool@. - type DemoteRep k :: * + type DemoteRep k :: Type -- | Convert a singleton to its unrefined version. fromSing :: Sing (a :: k) -> DemoteRep k diff --git a/GHC/IO.hs b/GHC/IO.hs --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -279,7 +279,9 @@ -- ^ the state during 'mask': asynchronous exceptions are masked, but blocking operations may still be interrupted | MaskedUninterruptible -- ^ the state during 'uninterruptibleMask': asynchronous exceptions are masked, and blocking operations may not be interrupted - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Returns the 'MaskingState' for the current thread. getMaskingState :: IO MaskingState @@ -334,7 +336,7 @@ -- 'MaskedInterruptible' state, -- use @mask_ $ forkIO ...@. This is particularly useful if you need -- to establish an exception handler in the forked thread before any --- asynchronous exceptions are received. To create a a new thread in +-- asynchronous exceptions are received. To create a new thread in -- an unmasked state use 'Control.Concurrent.forkIOWithUnmask'. -- mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b diff --git a/GHC/IO.hs-boot b/GHC/IO.hs-boot --- a/GHC/IO.hs-boot +++ b/GHC/IO.hs-boot @@ -4,6 +4,7 @@ module GHC.IO where import GHC.Types +import GHC.Integer () -- see Note [Depend upon GHC.Integer] in libraries/base/GHC/Base.hs failIO :: [Char] -> IO a mplusIO :: IO a -> IO a -> IO a diff --git a/GHC/IO/Buffer.hs b/GHC/IO/Buffer.hs --- a/GHC/IO/Buffer.hs +++ b/GHC/IO/Buffer.hs @@ -192,7 +192,8 @@ type CharBuffer = Buffer Char #endif -data BufferState = ReadBuffer | WriteBuffer deriving (Eq) +data BufferState = ReadBuffer | WriteBuffer + deriving Eq -- ^ @since 4.2.0.0 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f diff --git a/GHC/IO/Device.hs b/GHC/IO/Device.hs --- a/GHC/IO/Device.hs +++ b/GHC/IO/Device.hs @@ -154,7 +154,8 @@ -- read and write operations and may be seekable only -- to positions of certain granularity (block- -- aligned). - deriving (Eq) + deriving ( Eq -- ^ @since 4.2.0.0 + ) -- ----------------------------------------------------------------------------- -- SeekMode type @@ -166,5 +167,11 @@ -- from the current position. | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ -- from the end of the file. - deriving (Eq, Ord, Ix, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Ix -- ^ @since 4.2.0.0 + , Enum -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) diff --git a/GHC/IO/Encoding/Failure.hs b/GHC/IO/Encoding/Failure.hs --- a/GHC/IO/Encoding/Failure.hs +++ b/GHC/IO/Encoding/Failure.hs @@ -48,7 +48,8 @@ | RoundtripFailure -- ^ Use the private-use escape mechanism to attempt to allow -- illegal sequences to be roundtripped. - deriving (Show) + deriving ( Show -- ^ @since 4.4.0.0 + ) -- This will only work properly for those encodings which are -- strict supersets of ASCII in the sense that valid ASCII data -- is also valid in that encoding. This is not true for diff --git a/GHC/IO/Encoding/Types.hs b/GHC/IO/Encoding/Types.hs --- a/GHC/IO/Encoding/Types.hs +++ b/GHC/IO/Encoding/Types.hs @@ -129,5 +129,7 @@ | InvalidSequence -- ^ Stopped because there are sufficient free elements in the output -- to output at least one encoded ASCII character, but the input contains -- an invalid or unrepresentable sequence - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.4.0.0 + , Show -- ^ @since 4.4.0.0 + ) diff --git a/GHC/IO/Exception.hs b/GHC/IO/Exception.hs --- a/GHC/IO/Exception.hs +++ b/GHC/IO/Exception.hs @@ -226,7 +226,9 @@ -- ^This exception is raised by default in the main thread of -- the program when the user requests to terminate the program -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + ) -- | @since 4.7.0.0 instance Exception AsyncException where @@ -241,7 +243,9 @@ | UndefinedElement String -- ^An attempt was made to evaluate an element of an -- array that had not been initialized. - deriving (Eq, Ord) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + ) -- | @since 4.1.0.0 instance Exception ArrayException diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -45,6 +45,7 @@ import GHC.IO.Exception #if defined(mingw32_HOST_OS) import GHC.Windows +import Data.Bool #endif import Foreign @@ -401,7 +402,7 @@ return (toEnum (fromIntegral r)) foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> Int64 -> CInt -> IO CInt + fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt -- --------------------------------------------------------------------------- -- Terminal-related stuff @@ -562,7 +563,7 @@ isNonBlocking fd = fdIsNonBlocking fd /= 0 foreign import ccall unsafe "fdReady" - unsafe_fdReady :: CInt -> CInt -> Int64 -> CInt -> IO CInt + unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #else /* mingw32_HOST_OS.... */ @@ -589,8 +590,10 @@ (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt @@ -598,34 +601,46 @@ (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (fromIntegral len) (buf `plusPtr` off) if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + then let sock_errno = c_maperrno_func (fromIntegral rc) + non_sock_errno = Errno (fromIntegral rc) + errno = bool non_sock_errno sock_errno (fdIsSocket fd) + in ioError (errnoToIOError loc errno Nothing Nothing) else return (fromIntegral l) -- Blocking versions of the read/write primitives, for the threaded RTS blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt blockingReadRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len) + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0 + read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len) + r <- bool read_ret recv_ret (fdIsSocket fd) + when ((fdIsSocket fd) && (r == -1)) c_maperrno + return r + -- We trust read() to give us the correct errno but recv(), as a + -- Winsock function, doesn't do the errno conversion so if the fd + -- is for a socket, we do it from GetLastError() ourselves. blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt blockingWriteRawBufferPtr loc !fd !buf !off !len - = throwErrnoIfMinus1Retry loc $ - if fdIsSocket fd - then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 - else do - r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len) - when (r == -1) c_maperrno - return r - -- we don't trust write() to give us the correct errno, and + = throwErrnoIfMinus1Retry loc $ do + let start_ptr = buf `plusPtr` off + send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0 + write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len) + r <- bool write_ret send_ret (fdIsSocket fd) + when (r == -1) c_maperrno + return r + -- We don't trust write() to give us the correct errno, and -- instead do the errno conversion from GetLastError() - -- ourselves. The main reason is that we treat ERROR_NO_DATA + -- ourselves. The main reason is that we treat ERROR_NO_DATA -- (pipe is closing) as EPIPE, whereas write() returns EINVAL - -- for this case. We need to detect EPIPE correctly, because it + -- for this case. We need to detect EPIPE correctly, because it -- shouldn't be reported as an error when it happens on stdout. + -- As for send()'s case, Winsock functions don't do errno + -- conversion in any case so we have to do it ourselves. + -- That means we're doing the errno conversion no matter if the + -- fd is from a socket or not. -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. diff --git a/GHC/IO/Handle/Lock.hsc b/GHC/IO/Handle/Lock.hsc --- a/GHC/IO/Handle/Lock.hsc +++ b/GHC/IO/Handle/Lock.hsc @@ -63,8 +63,9 @@ -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported - deriving Show + deriving Show -- ^ @since 4.10.0.0 +-- ^ @since 4.10.0.0 instance Exception FileLockingNotSupported -- | Indicates a mode in which a file should be locked. diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs --- a/GHC/IO/Handle/Text.hs +++ b/GHC/IO/Handle/Text.hs @@ -537,6 +537,7 @@ -- overhead of a single putChar '\n', which is quite high now that we -- have to encode eagerly. +{-# NOINLINE hPutStr' #-} hPutStr' :: Handle -> String -> Bool -> IO () hPutStr' handle str add_nl = do diff --git a/GHC/IO/Handle/Types.hs b/GHC/IO/Handle/Types.hs --- a/GHC/IO/Handle/Types.hs +++ b/GHC/IO/Handle/Types.hs @@ -247,7 +247,11 @@ -- ^ block-buffering should be enabled if possible. -- The size of the buffer is @n@ items if the argument -- is 'Just' @n@ and is otherwise implementation-dependent. - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) {- [note Buffering Implementation] @@ -349,7 +353,11 @@ -- | The representation of a newline in the external file or stream. data Newline = LF -- ^ '\n' | CRLF -- ^ '\r\n' - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | Specifies the translation, if any, of newline characters between -- internal Strings and the external file or stream. Haskell Strings @@ -362,7 +370,11 @@ outputNL :: Newline -- ^ the representation of newlines on output } - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.3.0.0 + , Read -- ^ @since 4.3.0.0 + , Show -- ^ @since 4.3.0.0 + ) -- | The native newline representation for the current platform: 'LF' -- on Unix systems, 'CRLF' on Windows. diff --git a/GHC/IO/IOMode.hs b/GHC/IO/IOMode.hs --- a/GHC/IO/IOMode.hs +++ b/GHC/IO/IOMode.hs @@ -26,5 +26,11 @@ -- | See 'System.IO.openFile' data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) + deriving ( Eq -- ^ @since 4.2.0.0 + , Ord -- ^ @since 4.2.0.0 + , Ix -- ^ @since 4.2.0.0 + , Enum -- ^ @since 4.2.0.0 + , Read -- ^ @since 4.2.0.0 + , Show -- ^ @since 4.2.0.0 + ) diff --git a/GHC/IORef.hs b/GHC/IORef.hs --- a/GHC/IORef.hs +++ b/GHC/IORef.hs @@ -31,7 +31,7 @@ -- |A mutable variable in the 'IO' monad newtype IORef a = IORef (STRef RealWorld a) - deriving Eq + deriving Eq -- ^ @since 4.2.0.0 -- ^ Pointer equality. -- -- @since 4.1.0.0 diff --git a/GHC/Int.hs b/GHC/Int.hs --- a/GHC/Int.hs +++ b/GHC/Int.hs @@ -1082,6 +1082,36 @@ unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Int8" + fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt +"fromIntegral/Natural->Int16" + fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt +"fromIntegral/Natural->Int32" + fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt + #-} + +{-# RULES +"fromIntegral/Int8->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) +"fromIntegral/Int16->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) +"fromIntegral/Int32->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 & Int==Int64 +{-# RULES +"fromIntegral/Natural->Int64" + fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt +"fromIntegral/Int64->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) + #-} +#endif + {- Note [Order of tests] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/List.hs b/GHC/List.hs --- a/GHC/List.hs +++ b/GHC/List.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -947,12 +946,19 @@ ---------------------------------------------- -- | 'zip' takes two lists and returns a list of corresponding pairs. +-- +-- > zip [1, 2] ['a', 'b'] = [(1, 'a'), (2, 'b')] +-- -- If one input list is short, excess elements of the longer list are --- discarded. +-- discarded: -- +-- > zip [1] ['a', 'b'] = [(1, 'a')] +-- > zip [1, 2] ['a'] = [(1, 'a')] +-- -- 'zip' is right-lazy: -- -- > zip [] _|_ = [] +-- > zip _|_ [] = _|_ {-# NOINLINE [1] zip #-} zip :: [a] -> [b] -> [(a,b)] zip [] _bs = [] diff --git a/GHC/MVar.hs b/GHC/MVar.hs --- a/GHC/MVar.hs +++ b/GHC/MVar.hs @@ -38,7 +38,7 @@ {- ^ An 'MVar' (pronounced \"em-var\") is a synchronising variable, used for communication between concurrent threads. It can be thought of -as a a box, which may be empty or full. +as a box, which may be empty or full. -} -- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module diff --git a/GHC/Maybe.hs b/GHC/Maybe.hs new file mode 100644 --- /dev/null +++ b/GHC/Maybe.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Maybe type +module GHC.Maybe + ( Maybe (..) + ) +where + +import GHC.Integer () -- for build order +import GHC.Classes + +default () + +------------------------------------------------------------------------------- +-- Maybe type +------------------------------------------------------------------------------- + +-- | The 'Maybe' type encapsulates an optional value. A value of type +-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic +-- measures such as 'error'. +-- +-- The 'Maybe' type is also a monad. It is a simple kind of error +-- monad, where all errors are represented by 'Nothing'. A richer +-- error monad can be built using the 'Data.Either.Either' type. +-- +data Maybe a = Nothing | Just a + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) diff --git a/GHC/Natural.hs b/GHC/Natural.hs --- a/GHC/Natural.hs +++ b/GHC/Natural.hs @@ -1,13 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE Unsafe #-} -{-# OPTIONS_HADDOCK not-home #-} - ----------------------------------------------------------------------------- -- | -- Module : GHC.Natural @@ -34,38 +30,76 @@ -- (i.e. which constructors are available) depends on the -- 'Integer' backend used! Natural(..) + , mkNatural , isValidNatural + -- * Arithmetic + , plusNatural + , minusNatural + , minusNaturalMaybe + , timesNatural + , negateNatural + , signumNatural + , quotRemNatural + , quotNatural + , remNatural +#if defined(MIN_VERSION_integer_gmp) + , gcdNatural + , lcmNatural +#endif + -- * Bits + , andNatural + , orNatural + , xorNatural + , bitNatural + , testBitNatural +#if defined(MIN_VERSION_integer_gmp) + , popCountNatural +#endif + , shiftLNatural + , shiftRNatural -- * Conversions + , naturalToInteger + , naturalToWord + , naturalToInt , naturalFromInteger , wordToNatural + , intToNatural , naturalToWordMaybe - -- * Checked subtraction - , minusNaturalMaybe + , wordToNatural# + , wordToNaturalBase -- * Modular arithmetic , powModNatural ) where #include "MachDeps.h" -import GHC.Arr -import GHC.Base -import {-# SOURCE #-} GHC.Exception (underflowException) +import GHC.Classes +import GHC.Maybe +import GHC.Types +import GHC.Prim +import {-# SOURCE #-} GHC.Exception.Type (underflowException, divZeroException) #if defined(MIN_VERSION_integer_gmp) import GHC.Integer.GMP.Internals -import Data.Word -import Data.Int +#else +import GHC.Integer #endif -import GHC.Num -import GHC.Real -import GHC.Read -import GHC.Show -import GHC.Enum -import GHC.List -import Data.Bits - default () +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Natural`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusNatural #-} +-- +-- which is simply expanded into a +-- +-- {-# NOINLINE plusNatural #-} +-- +#define CONSTANT_FOLDED NOINLINE + ------------------------------------------------------------------------------- -- Arithmetic underflow ------------------------------------------------------------------------------- @@ -77,6 +111,10 @@ underflowError :: a underflowError = raise# underflowException +{-# NOINLINE divZeroError #-} +divZeroError :: a +divZeroError = raise# divZeroException + ------------------------------------------------------------------------------- -- Natural type ------------------------------------------------------------------------------- @@ -86,7 +124,7 @@ -- | Type representing arbitrary-precision non-negative integers. -- --- >>> 2^20 :: Natural +-- >>> 2^100 :: Natural -- 1267650600228229401496703205376 -- -- Operations whose result would be negative @'throw' ('Underflow' :: 'ArithException')@, @@ -101,9 +139,13 @@ -- __Invariant__: 'NatJ#' is used -- /iff/ value doesn't fit in -- 'NatS#' constructor. - deriving (Eq,Ord) -- NB: Order of constructors *must* + -- NB: Order of constructors *must* -- coincide with 'Ord' relation + deriving ( Eq -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + ) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- -- This operation is mostly useful for test-suites and/or code which @@ -113,107 +155,32 @@ isValidNatural :: Natural -> Bool isValidNatural (NatS# _) = True isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) - && I# (sizeofBigNat# bn) > 0 - -{-# RULES -"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural -"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer -"fromIntegral/Natural->Word" fromIntegral = naturalToWord -"fromIntegral/Natural->Word8" - fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord -"fromIntegral/Natural->Word16" - fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord -"fromIntegral/Natural->Word32" - fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord -"fromIntegral/Natural->Int8" - fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt -"fromIntegral/Natural->Int16" - fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt -"fromIntegral/Natural->Int32" - fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt - #-} - -{-# RULES -"fromIntegral/Word->Natural" fromIntegral = wordToNatural -"fromIntegral/Word8->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) -"fromIntegral/Word16->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) -"fromIntegral/Word32->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) -"fromIntegral/Int->Natural" fromIntegral = intToNatural -"fromIntegral/Int8->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) -"fromIntegral/Int16->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) -"fromIntegral/Int32->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) - #-} - -#if WORD_SIZE_IN_BITS == 64 --- these RULES are valid for Word==Word64 & Int==Int64 -{-# RULES -"fromIntegral/Natural->Word64" - fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord -"fromIntegral/Natural->Int64" - fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt -"fromIntegral/Word64->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) -"fromIntegral/Int64->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) - #-} -#endif - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec p (NatS# w#) = showsPrec p (W# w#) - showsPrec p (NatJ# bn) = showsPrec p (Jp# bn) - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (fromInteger n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Num Natural where - fromInteger = naturalFromInteger - - (+) = plusNatural - (*) = timesNatural - (-) = minusNatural - - abs = id + && isTrue# (sizeofBigNat# bn ># 0#) - signum (NatS# 0##) = NatS# 0## - signum _ = NatS# 1## +signumNatural :: Natural -> Natural +signumNatural (NatS# 0##) = NatS# 0## +signumNatural _ = NatS# 1## +{-# CONSTANT_FOLDED signumNatural #-} - negate (NatS# 0##) = NatS# 0## - negate _ = underflowError +negateNatural :: Natural -> Natural +negateNatural (NatS# 0##) = NatS# 0## +negateNatural _ = underflowError +{-# CONSTANT_FOLDED negateNatural #-} -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural -naturalFromInteger (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) -naturalFromInteger (Jp# bn) = bigNatToNatural bn -naturalFromInteger _ = underflowError -{-# INLINE naturalFromInteger #-} - --- | @since 4.8.0.0 -instance Real Natural where - toRational (NatS# w) = toRational (W# w) - toRational (NatJ# bn) = toRational (Jp# bn) - -#if OPTIMISE_INTEGER_GCD_LCM -{-# RULES -"gcd/Natural->Natural->Natural" gcd = gcdNatural -"lcm/Natural->Natural->Natural" lcm = lcmNatural - #-} +naturalFromInteger (S# i#) + | isTrue# (i# >=# 0#) = NatS# (int2Word# i#) +naturalFromInteger (Jp# bn) = bigNatToNatural bn +naturalFromInteger _ = underflowError +{-# CONSTANT_FOLDED naturalFromInteger #-} -- | Compute greatest common divisor. gcdNatural :: Natural -> Natural -> Natural gcdNatural (NatS# 0##) y = y gcdNatural x (NatS# 0##) = x -gcdNatural (NatS# 1##) _ = (NatS# 1##) -gcdNatural _ (NatS# 1##) = (NatS# 1##) +gcdNatural (NatS# 1##) _ = NatS# 1## +gcdNatural _ (NatS# 1##) = NatS# 1## gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y) gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y) gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x) @@ -221,162 +188,107 @@ -- | compute least common multiplier. lcmNatural :: Natural -> Natural -> Natural -lcmNatural (NatS# 0##) _ = (NatS# 0##) -lcmNatural _ (NatS# 0##) = (NatS# 0##) +lcmNatural (NatS# 0##) _ = NatS# 0## +lcmNatural _ (NatS# 0##) = NatS# 0## lcmNatural (NatS# 1##) y = y lcmNatural x (NatS# 1##) = x -lcmNatural x y = (x `quot` (gcdNatural x y)) * y - -#endif - --- | @since 4.8.0.0 -instance Enum Natural where - succ n = n `plusNatural` NatS# 1## - pred n = n `minusNatural` NatS# 1## - - toEnum = intToNatural - - fromEnum (NatS# w) | i >= 0 = i - where - i = fromIntegral (W# w) - fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" - - enumFrom x = enumDeltaNatural x (NatS# 1##) - enumFromThen x y - | x <= y = enumDeltaNatural x (y-x) - | otherwise = enumNegDeltaToNatural x (x-y) (NatS# 0##) - - enumFromTo x lim = enumDeltaToNatural x (NatS# 1##) lim - enumFromThenTo x y lim - | x <= y = enumDeltaToNatural x (y-x) lim - | otherwise = enumNegDeltaToNatural x (x-y) lim - ----------------------------------------------------------------------------- --- Helpers for 'Enum Natural'; TODO: optimise & make fusion work - -enumDeltaNatural :: Natural -> Natural -> [Natural] -enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d - -enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumDeltaToNatural x0 delta lim = go x0 - where - go x | x > lim = [] - | otherwise = x : go (x+delta) - -enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumNegDeltaToNatural x0 ndelta lim = go x0 - where - go x | x < lim = [] - | x >= ndelta = x : go (x-ndelta) - | otherwise = [x] +lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y ---------------------------------------------------------------------------- --- | @since 4.8.0.0 -instance Integral Natural where - toInteger (NatS# w) = wordToInteger w - toInteger (NatJ# bn) = Jp# bn - - divMod = quotRem - div = quot - mod = rem - - quotRem _ (NatS# 0##) = divZeroError - quotRem n (NatS# 1##) = (n,NatS# 0##) - quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n) - quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of - (q,r) -> (wordToNatural q, wordToNatural r) - quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of - (# q,r #) -> (bigNatToNatural q, NatS# r) - quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of - (# q,r #) -> (bigNatToNatural q, bigNatToNatural r) - - quot _ (NatS# 0##) = divZeroError - quot n (NatS# 1##) = n - quot (NatS# _) (NatJ# _) = NatS# 0## - quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d)) - quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) - quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) - - rem _ (NatS# 0##) = divZeroError - rem _ (NatS# 1##) = NatS# 0## - rem n@(NatS# _) (NatJ# _) = n - rem (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d)) - rem (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) - rem (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) - --- | @since 4.8.0.0 -instance Ix Natural where - range (m,n) = [m..n] - inRange (m,n) i = m <= i && i <= n - unsafeIndex (m,_) i = fromIntegral (i-m) - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Natural" - - --- | @since 4.8.0.0 -instance Bits Natural where - NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m) - NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m)) - NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m) - NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m) - - NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m) - NatS# n .|. NatJ# m = NatJ# (orBigNat (wordToBigNat n) m) - NatJ# n .|. NatS# m = NatJ# (orBigNat n (wordToBigNat m)) - NatJ# n .|. NatJ# m = NatJ# (orBigNat n m) - - NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m) - NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m) - NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) - NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural _ (NatS# 0##) = divZeroError +quotRemNatural n (NatS# 1##) = (n,NatS# 0##) +quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n) +quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of + (# q, r #) -> (NatS# q, NatS# r) +quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of + (# q, r #) -> (bigNatToNatural q, NatS# r) +quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of + (# q, r #) -> (bigNatToNatural q, bigNatToNatural r) +{-# CONSTANT_FOLDED quotRemNatural #-} - bitSizeMaybe _ = Nothing - bitSize = errorWithoutStackTrace "Natural: bitSize" - isSigned _ = False +quotNatural :: Natural -> Natural -> Natural +quotNatural _ (NatS# 0##) = divZeroError +quotNatural n (NatS# 1##) = n +quotNatural (NatS# _) (NatJ# _) = NatS# 0## +quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) +quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) +quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) +{-# CONSTANT_FOLDED quotNatural #-} - bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) - | otherwise = NatJ# (bitBigNat i#) +remNatural :: Natural -> Natural -> Natural +remNatural _ (NatS# 0##) = divZeroError +remNatural _ (NatS# 1##) = NatS# 0## +remNatural n@(NatS# _) (NatJ# _) = n +remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) +remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) +remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) +{-# CONSTANT_FOLDED remNatural #-} - testBit (NatS# w) i = testBit (W# w) i - testBit (NatJ# bn) (I# i#) = testBitBigNat bn i# +-- | @since 4.X.0.0 +naturalToInteger :: Natural -> Integer +naturalToInteger (NatS# w) = wordToInteger w +naturalToInteger (NatJ# bn) = Jp# bn +{-# CONSTANT_FOLDED naturalToInteger #-} - clearBit n@(NatS# w#) i - | i < finiteBitSize (0::Word) = let !(W# w2#) = clearBit (W# w#) i in NatS# w2# - | otherwise = n - clearBit (NatJ# bn) (I# i#) = bigNatToNatural (clearBitBigNat bn i#) +andNatural :: Natural -> Natural -> Natural +andNatural (NatS# n) (NatS# m) = NatS# (n `and#` m) +andNatural (NatS# n) (NatJ# m) = NatS# (n `and#` bigNatToWord m) +andNatural (NatJ# n) (NatS# m) = NatS# (bigNatToWord n `and#` m) +andNatural (NatJ# n) (NatJ# m) = bigNatToNatural (andBigNat n m) +{-# CONSTANT_FOLDED andNatural #-} - setBit (NatS# w#) i@(I# i#) - | i < finiteBitSize (0::Word) = let !(W# w2#) = setBit (W# w#) i in NatS# w2# - | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#) - setBit (NatJ# bn) (I# i#) = bigNatToNatural (setBitBigNat bn i#) +orNatural :: Natural -> Natural -> Natural +orNatural (NatS# n) (NatS# m) = NatS# (n `or#` m) +orNatural (NatS# n) (NatJ# m) = NatJ# (orBigNat (wordToBigNat n) m) +orNatural (NatJ# n) (NatS# m) = NatJ# (orBigNat n (wordToBigNat m)) +orNatural (NatJ# n) (NatJ# m) = NatJ# (orBigNat n m) +{-# CONSTANT_FOLDED orNatural #-} - complementBit (NatS# w#) i@(I# i#) - | i < finiteBitSize (0::Word) = let !(W# w2#) = complementBit (W# w#) i in NatS# w2# - | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#) - complementBit (NatJ# bn) (I# i#) = bigNatToNatural (complementBitBigNat bn i#) +xorNatural :: Natural -> Natural -> Natural +xorNatural (NatS# n) (NatS# m) = NatS# (n `xor#` m) +xorNatural (NatS# n) (NatJ# m) = NatJ# (xorBigNat (wordToBigNat n) m) +xorNatural (NatJ# n) (NatS# m) = NatJ# (xorBigNat n (wordToBigNat m)) +xorNatural (NatJ# n) (NatJ# m) = bigNatToNatural (xorBigNat n m) +{-# CONSTANT_FOLDED xorNatural #-} - shiftL n 0 = n - shiftL (NatS# 0##) _ = NatS# 0## - shiftL (NatS# 1##) i = bit i - shiftL (NatS# w) (I# i#) - = bigNatToNatural $ shiftLBigNat (wordToBigNat w) i# - shiftL (NatJ# bn) (I# i#) - = bigNatToNatural $ shiftLBigNat bn i# +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = NatS# (1## `uncheckedShiftL#` i#) + | True = NatJ# (bitBigNat i#) +{-# CONSTANT_FOLDED bitNatural #-} - shiftR n 0 = n - shiftR (NatS# w) i = wordToNatural $ shiftR (W# w) i - shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) +testBitNatural :: Natural -> Int -> Bool +testBitNatural (NatS# w) (I# i#) + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = + isTrue# ((w `and#` (1## `uncheckedShiftL#` i#)) `neWord#` 0##) + | True = False +testBitNatural (NatJ# bn) (I# i#) = testBitBigNat bn i# +{-# CONSTANT_FOLDED testBitNatural #-} - rotateL = shiftL - rotateR = shiftR +popCountNatural :: Natural -> Int +popCountNatural (NatS# w) = I# (word2Int# (popCnt# w)) +popCountNatural (NatJ# bn) = I# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountNatural #-} - popCount (NatS# w) = popCount (W# w) - popCount (NatJ# bn) = I# (popCountBigNat bn) +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural n (I# 0#) = n +shiftLNatural (NatS# 0##) _ = NatS# 0## +shiftLNatural (NatS# 1##) (I# i#) = bitNatural i# +shiftLNatural (NatS# w) (I# i#) + = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#) +shiftLNatural (NatJ# bn) (I# i#) + = bigNatToNatural (shiftLBigNat bn i#) +{-# CONSTANT_FOLDED shiftLNatural #-} - zeroBits = NatS# 0## +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural n (I# 0#) = n +shiftRNatural (NatS# w) (I# i#) + | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0## + | True = NatS# (w `uncheckedShiftRL#` i#) +shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) +{-# CONSTANT_FOLDED shiftRNatural #-} ---------------------------------------------------------------------------- @@ -391,6 +303,7 @@ plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x) plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y) plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y) +{-# CONSTANT_FOLDED plusNatural #-} -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural @@ -401,10 +314,11 @@ timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of (# 0##, 0## #) -> NatS# 0## (# 0##, xy #) -> NatS# xy - (# h , l #) -> NatJ# $ wordToBigNat2 h l -timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x -timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y -timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat x y + (# h , l #) -> NatJ# (wordToBigNat2 h l) +timesNatural (NatS# x) (NatJ# y) = NatJ# (timesBigNatWord y x) +timesNatural (NatJ# x) (NatS# y) = NatJ# (timesBigNatWord x y) +timesNatural (NatJ# x) (NatJ# y) = NatJ# (timesBigNat x y) +{-# CONSTANT_FOLDED timesNatural #-} -- | 'Natural' subtraction. May @'throw' 'Underflow'@. minusNatural :: Natural -> Natural -> Natural @@ -414,9 +328,10 @@ _ -> underflowError minusNatural (NatS# _) (NatJ# _) = underflowError minusNatural (NatJ# x) (NatS# y) - = bigNatToNatural $ minusBigNatWord x y + = bigNatToNatural (minusBigNatWord x y) minusNatural (NatJ# x) (NatJ# y) - = bigNatToNatural $ minusBigNat x y + = bigNatToNatural (minusBigNat x y) +{-# CONSTANT_FOLDED minusNatural #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- @@ -426,13 +341,12 @@ minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of (# l, 0# #) -> Just (NatS# l) _ -> Nothing - where minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing minusNaturalMaybe (NatJ# x) (NatS# y) - = Just $ bigNatToNatural $ minusBigNatWord x y + = Just (bigNatToNatural (minusBigNatWord x y)) minusNaturalMaybe (NatJ# x) (NatJ# y) | isTrue# (isNullBigNat# res) = Nothing - | otherwise = Just (bigNatToNatural res) + | True = Just (bigNatToNatural res) where res = minusBigNat x y @@ -442,18 +356,12 @@ bigNatToNatural bn | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn) | isTrue# (isNullBigNat# bn) = underflowError - | otherwise = NatJ# bn + | True = NatJ# bn naturalToBigNat :: Natural -> BigNat naturalToBigNat (NatS# w#) = wordToBigNat w# naturalToBigNat (NatJ# bn) = bn --- | Convert 'Int' to 'Natural'. --- Throws 'Underflow' when passed a negative 'Int'. -intToNatural :: Int -> Natural -intToNatural i | i<0 = underflowError -intToNatural (I# i#) = NatS# (int2Word# i#) - naturalToWord :: Natural -> Word naturalToWord (NatS# w#) = W# w# naturalToWord (NatJ# bn) = W# (bigNatToWord bn) @@ -462,6 +370,23 @@ naturalToInt (NatS# w#) = I# (word2Int# w#) naturalToInt (NatJ# bn) = I# (bigNatToInt bn) +---------------------------------------------------------------------------- + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w# = NatS# w# +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w# = NatS# w# + #else /* !defined(MIN_VERSION_integer_gmp) */ ---------------------------------------------------------------------------- -- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package @@ -473,156 +398,141 @@ -- -- @since 4.8.0.0 newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer' - deriving (Eq,Ord,Ix) + deriving (Eq,Ord) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- -- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. +-- constructs 'Natural' values directly. -- -- @since 4.8.0.0 isValidNatural :: Natural -> Bool -isValidNatural (Natural i) = i >= 0 - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (Natural n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +isValidNatural (Natural i) = i >= wordToInteger 0## --- | @since 4.8.0.0 -instance Show Natural where - showsPrec d (Natural i) = showsPrec d i +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w## = Natural (wordToInteger w##) +{-# CONSTANT_FOLDED wordToNatural# #-} --- | @since 4.8.0.0 -instance Num Natural where - Natural n + Natural m = Natural (n + m) - {-# INLINE (+) #-} - Natural n * Natural m = Natural (n * m) - {-# INLINE (*) #-} - Natural n - Natural m | result < 0 = underflowError - | otherwise = Natural result - where result = n - m - {-# INLINE (-) #-} - abs (Natural n) = Natural n - {-# INLINE abs #-} - signum (Natural n) = Natural (signum n) - {-# INLINE signum #-} - fromInteger = naturalFromInteger - {-# INLINE fromInteger #-} +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w## = Natural (wordToInteger w##) -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural naturalFromInteger n - | n >= 0 = Natural n - | otherwise = underflowError + | n >= wordToInteger 0## = Natural n + | True = underflowError {-# INLINE naturalFromInteger #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural -minusNaturalMaybe x y - | x >= y = Just (x - y) - | otherwise = Nothing +minusNaturalMaybe (Natural x) (Natural y) + | x >= y = Just (Natural (x `minusInteger` y)) + | True = Nothing --- | @since 4.8.0.0 -instance Bits Natural where - Natural n .&. Natural m = Natural (n .&. m) - {-# INLINE (.&.) #-} - Natural n .|. Natural m = Natural (n .|. m) - {-# INLINE (.|.) #-} - xor (Natural n) (Natural m) = Natural (xor n m) - {-# INLINE xor #-} - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - {-# INLINE complement #-} - shift (Natural n) = Natural . shift n - {-# INLINE shift #-} - rotate (Natural n) = Natural . rotate n - {-# INLINE rotate #-} - bit = Natural . bit - {-# INLINE bit #-} - setBit (Natural n) = Natural . setBit n - {-# INLINE setBit #-} - clearBit (Natural n) = Natural . clearBit n - {-# INLINE clearBit #-} - complementBit (Natural n) = Natural . complementBit n - {-# INLINE complementBit #-} - testBit (Natural n) = testBit n - {-# INLINE testBit #-} - bitSizeMaybe _ = Nothing - {-# INLINE bitSizeMaybe #-} - bitSize = errorWithoutStackTrace "Natural: bitSize" - {-# INLINE bitSize #-} - isSigned _ = False - {-# INLINE isSigned #-} - shiftL (Natural n) = Natural . shiftL n - {-# INLINE shiftL #-} - shiftR (Natural n) = Natural . shiftR n - {-# INLINE shiftR #-} - rotateL (Natural n) = Natural . rotateL n - {-# INLINE rotateL #-} - rotateR (Natural n) = Natural . rotateR n - {-# INLINE rotateR #-} - popCount (Natural n) = popCount n - {-# INLINE popCount #-} - zeroBits = Natural 0 +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural (Natural n) (I# i) = Natural (n `shiftLInteger` i) +{-# CONSTANT_FOLDED shiftLNatural #-} --- | @since 4.8.0.0 -instance Real Natural where - toRational (Natural a) = toRational a - {-# INLINE toRational #-} +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural (Natural n) (I# i) = Natural (n `shiftRInteger` i) +{-# CONSTANT_FOLDED shiftRNatural #-} --- | @since 4.8.0.0 -instance Enum Natural where - pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" - pred (Natural n) = Natural (pred n) - {-# INLINE pred #-} - succ (Natural n) = Natural (succ n) - {-# INLINE succ #-} - fromEnum (Natural n) = fromEnum n - {-# INLINE fromEnum #-} - toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" - | otherwise = Natural (toEnum n) - {-# INLINE toEnum #-} +plusNatural :: Natural -> Natural -> Natural +plusNatural (Natural x) (Natural y) = Natural (x `plusInteger` y) +{-# CONSTANT_FOLDED plusNatural #-} - enumFrom = coerce (enumFrom :: Integer -> [Integer]) - enumFromThen x y - | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y - | otherwise = enumFromThenTo x y 0 +minusNatural :: Natural -> Natural -> Natural +minusNatural (Natural x) (Natural y) = Natural (x `minusInteger` y) +{-# CONSTANT_FOLDED minusNatural #-} - enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) - enumFromThenTo - = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) +timesNatural :: Natural -> Natural -> Natural +timesNatural (Natural x) (Natural y) = Natural (x `timesInteger` y) +{-# CONSTANT_FOLDED timesNatural #-} --- | @since 4.8.0.0 -instance Integral Natural where - quot (Natural a) (Natural b) = Natural (quot a b) - {-# INLINE quot #-} - rem (Natural a) (Natural b) = Natural (rem a b) - {-# INLINE rem #-} - div (Natural a) (Natural b) = Natural (div a b) - {-# INLINE div #-} - mod (Natural a) (Natural b) = Natural (mod a b) - {-# INLINE mod #-} - divMod (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = divMod a b - {-# INLINE divMod #-} - quotRem (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = quotRem a b - {-# INLINE quotRem #-} - toInteger (Natural a) = a - {-# INLINE toInteger #-} +orNatural :: Natural -> Natural -> Natural +orNatural (Natural x) (Natural y) = Natural (x `orInteger` y) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (Natural x) (Natural y) = Natural (x `xorInteger` y) +{-# CONSTANT_FOLDED xorNatural #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (Natural x) (Natural y) = Natural (x `andInteger` y) +{-# CONSTANT_FOLDED andNatural #-} + +naturalToInt :: Natural -> Int +naturalToInt (Natural i) = I# (integerToInt i) + +naturalToWord :: Natural -> Word +naturalToWord (Natural i) = W# (integerToWord i) + +naturalToInteger :: Natural -> Integer +naturalToInteger (Natural i) = i +{-# CONSTANT_FOLDED naturalToInteger #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (Natural n) (I# i) = testBitInteger n i +{-# CONSTANT_FOLDED testBitNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = wordToNaturalBase (1## `uncheckedShiftL#` i#) + | True = Natural (1 `shiftLInteger` i#) +{-# CONSTANT_FOLDED bitNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = n + | True = Natural (x `quotInteger` y) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural (Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = wordToNaturalBase 0## + | True = Natural (x `remInteger` y) +{-# CONSTANT_FOLDED remNatural #-} + +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = (n,wordToNaturalBase 0##) + | True = case quotRemInteger x y of + (# k, r #) -> (Natural k, Natural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +signumNatural :: Natural -> Natural +signumNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = wordToNaturalBase 1## +{-# CONSTANT_FOLDED signumNatural #-} + +negateNatural :: Natural -> Natural +negateNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = underflowError +{-# CONSTANT_FOLDED negateNatural #-} + #endif -- | Construct 'Natural' from 'Word' value. -- -- @since 4.8.0.0 wordToNatural :: Word -> Natural -#if defined(MIN_VERSION_integer_gmp) -wordToNatural (W# w#) = NatS# w# -#else -wordToNatural w = Natural (fromIntegral w) -#endif +wordToNatural (W# w#) = wordToNatural# w# -- | Try downcasting 'Natural' to 'Word' value. -- Returns 'Nothing' if value doesn't fit in 'Word'. @@ -634,10 +544,10 @@ naturalToWordMaybe (NatJ# _) = Nothing #else naturalToWordMaybe (Natural i) - | i <= maxw = Just (fromIntegral i) - | otherwise = Nothing + | i < maxw = Just (W# (integerToWord i)) + | True = Nothing where - maxw = toInteger (maxBound :: Word) + maxw = 1 `shiftLInteger` WORD_SIZE_IN_BITS# #endif -- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to @@ -658,18 +568,38 @@ = bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m) #else -- Portable reference fallback implementation -powModNatural _ _ 0 = divZeroError -powModNatural _ _ 1 = 0 -powModNatural _ 0 _ = 1 -powModNatural 0 _ _ = 0 -powModNatural 1 _ _ = 1 -powModNatural b0 e0 m = go b0 e0 1 +powModNatural (Natural b0) (Natural e0) (Natural m) + | m == wordToInteger 0## = divZeroError + | m == wordToInteger 1## = wordToNaturalBase 0## + | e0 == wordToInteger 0## = wordToNaturalBase 1## + | b0 == wordToInteger 0## = wordToNaturalBase 0## + | b0 == wordToInteger 1## = wordToNaturalBase 1## + | True = go b0 e0 (wordToInteger 1##) where go !b e !r - | odd e = go b' e' (r*b `mod` m) - | e == 0 = r - | otherwise = go b' e' r + | e `testBitInteger` 0# = go b' e' ((r `timesInteger` b) `modInteger` m) + | e == wordToInteger 0## = naturalFromInteger r + | True = go b' e' r where - b' = b*b `mod` m - e' = e `unsafeShiftR` 1 -- slightly faster than "e `div` 2" + b' = (b `timesInteger` b) `modInteger` m + e' = e `shiftRInteger` 1# -- slightly faster than "e `div` 2" #endif + + +-- | Construct 'Natural' value from list of 'Word's. +-- +-- This function is used by GHC for constructing 'Natural' literals. +mkNatural :: [Word] -- ^ value expressed in 32 bit chunks, least + -- significant first + -> Natural +mkNatural [] = wordToNaturalBase 0## +mkNatural (W# i : is') = wordToNaturalBase (i `and#` 0xffffffff##) `orNatural` + shiftLNatural (mkNatural is') 32 +{-# CONSTANT_FOLDED mkNatural #-} + +-- | Convert 'Int' to 'Natural'. +-- Throws 'Underflow' when passed a negative 'Int'. +intToNatural :: Int -> Natural +intToNatural (I# i#) + | isTrue# (i# <# 0#) = underflowError + | True = wordToNaturalBase (int2Word# i#) diff --git a/GHC/Num.hs b/GHC/Num.hs --- a/GHC/Num.hs +++ b/GHC/Num.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -16,10 +16,17 @@ -- ----------------------------------------------------------------------------- -module GHC.Num (module GHC.Num, module GHC.Integer) where +module GHC.Num (module GHC.Num, module GHC.Integer, module GHC.Natural) where + +#include "MachDeps.h" + import GHC.Base import GHC.Integer +import GHC.Natural +#if !defined(MIN_VERSION_integer_gmp) +import {-# SOURCE #-} GHC.Exception.Type (underflowException) +#endif infixl 7 * infixl 6 +, - @@ -28,6 +35,23 @@ -- and we shouldn't be using defaults anyway -- | Basic numeric class. +-- +-- The Haskell Report defines no laws for 'Num'. However, '(+)' and '(*)' are +-- customarily expected to define a ring and have the following properties: +-- +-- [__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@ +-- [__Commutativity of (+)__]: @x + y@ = @y + x@ +-- [__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@ +-- [__'negate' gives the additive inverse__]: @x + negate x@ = @fromInteger 0@ +-- [__Associativity of (*)__]: @(x * y) * z@ = @x * (y * z)@ +-- [__@fromInteger 1@ is the multiplicative identity__]: +-- @x * fromInteger 1@ = @x@ and @fromInteger 1 * x@ = @x@ +-- [__Distributivity of (*) with respect to (+)__]: +-- @a * (b + c)@ = @(a * b) + (a * c)@ and @(b + c) * a@ = @(b * a) + (c * a)@ +-- +-- Note that it /isn't/ customarily expected that a type instance of both 'Num' +-- and 'Ord' implement an ordered ring. Indeed, in 'base' only 'Integer' and +-- 'Rational' do. class Num a where {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-} @@ -100,3 +124,41 @@ abs = absInteger signum = signumInteger + +#if defined(MIN_VERSION_integer_gmp) +-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an +-- additive inverse. It is a semiring though. +-- +-- @since 4.8.0.0 +instance Num Natural where + (+) = plusNatural + (-) = minusNatural + (*) = timesNatural + negate = negateNatural + fromInteger = naturalFromInteger + + abs = id + signum = signumNatural + +#else +-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an +-- additive inverse. It is a semiring though. +-- +-- @since 4.8.0.0 +instance Num Natural where + Natural n + Natural m = Natural (n + m) + {-# INLINE (+) #-} + Natural n * Natural m = Natural (n * m) + {-# INLINE (*) #-} + Natural n - Natural m + | m > n = raise# underflowException + | otherwise = Natural (n - m) + {-# INLINE (-) #-} + abs (Natural n) = Natural n + {-# INLINE abs #-} + signum (Natural n) = Natural (signum n) + {-# INLINE signum #-} + fromInteger = naturalFromInteger + {-# INLINE fromInteger #-} + +#endif diff --git a/GHC/PArr.hs b/GHC/PArr.hs deleted file mode 100644 --- a/GHC/PArr.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ParallelArrays, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.PArr --- Copyright : (c) 2001-2011 The Data Parallel Haskell team --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- BIG UGLY HACK: The desugarer special cases this module. Despite the uses of '-XParallelArrays', --- the desugarer does not load 'Data.Array.Parallel' into its global state. (Hence, --- the present module may not use any other piece of '-XParallelArray' syntax.) --- --- This will be cleaned up when we change the internal represention of '[::]' to not --- rely on a wired-in type constructor. - -module GHC.PArr where - -import GHC.Base - --- Representation of parallel arrays --- --- Vanilla representation of parallel Haskell based on standard GHC arrays that is used if the --- vectorised is /not/ used. --- --- NB: This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! --- -data [::] e = PArr !Int (Array# e) - -type PArr = [::] -- this synonym is to get access to '[::]' without using the special syntax diff --git a/GHC/Ptr.hs b/GHC/Ptr.hs --- a/GHC/Ptr.hs +++ b/GHC/Ptr.hs @@ -42,7 +42,10 @@ -- redundant role annotation checks that this doesn't change type role Ptr phantom -data Ptr a = Ptr Addr# deriving (Eq, Ord) +data Ptr a = Ptr Addr# + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) -- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an -- array of objects, which may be marshalled to or from Haskell values -- of type @a@. diff --git a/GHC/RTS/Flags.hsc b/GHC/RTS/Flags.hsc --- a/GHC/RTS/Flags.hsc +++ b/GHC/RTS/Flags.hsc @@ -66,7 +66,8 @@ | OneLineGCStats | SummaryGCStats | VerboseGCStats - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum GiveGCStats where @@ -115,7 +116,8 @@ , allocLimitGrace :: Word , numa :: Bool , numaMask :: Word - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters concerning context switching -- @@ -123,7 +125,8 @@ data ConcFlags = ConcFlags { ctxtSwitchTime :: RtsTime , ctxtSwitchTicks :: Int - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Miscellaneous parameters -- @@ -135,9 +138,11 @@ , generateCrashDumpFile :: Bool , generateStackTrace :: Bool , machineReadable :: Bool + , internalCounters :: Bool , linkerMemBase :: Word -- ^ address to ask the OS for memory for the linker, 0 ==> off - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Flags to control debugging output & extra checking in various -- subsystems. @@ -159,7 +164,8 @@ , squeeze :: Bool -- ^ 'z' stack squeezing & lazy blackholing , hpc :: Bool -- ^ 'c' coverage , sparks :: Bool -- ^ 'r' - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Should the RTS produce a cost-center summary? -- @@ -170,7 +176,8 @@ | CostCentresVerbose | CostCentresAll | CostCentresJSON - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoCostCentres where @@ -194,7 +201,8 @@ { doCostCentres :: DoCostCentres , profilerTicks :: Int , msecsPerTick :: Int - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | What sort of heap profile are we collecting? -- @@ -208,7 +216,8 @@ | HeapByRetainer | HeapByLDV | HeapByClosureType - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoHeapProfile where @@ -249,7 +258,8 @@ , ccsSelector :: Maybe String , retainerSelector :: Maybe String , bioSelector :: Maybe String - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Is event tracing enabled? -- @@ -258,7 +268,8 @@ = TraceNone -- ^ no tracing | TraceEventLog -- ^ send tracing events to the event log | TraceStderr -- ^ send tracing events to @stderr@ - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Enum DoTrace where @@ -282,7 +293,8 @@ , sparksSampled :: Bool -- ^ trace spark events by a sampled method , sparksFull :: Bool -- ^ trace spark events 100% accurately , user :: Bool -- ^ trace user events (emitted from Haskell code) - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters pertaining to ticky-ticky profiler -- @@ -290,7 +302,8 @@ data TickyFlags = TickyFlags { showTickyStats :: Bool , tickyFile :: Maybe FilePath - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters pertaining to parallelism -- @@ -307,7 +320,8 @@ , parGcThreads :: Word32 , setAffinity :: Bool } - deriving (Show) + deriving ( Show -- ^ @since 4.8.0.0 + ) -- | Parameters of the runtime system -- @@ -322,7 +336,8 @@ , traceFlags :: TraceFlags , tickyFlags :: TickyFlags , parFlags :: ParFlags - } deriving (Show) + } deriving ( Show -- ^ @since 4.8.0.0 + ) foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr RTSFlags @@ -427,6 +442,8 @@ (#{peek MISC_FLAGS, generate_stack_trace} ptr :: IO CBool)) <*> (toBool <$> (#{peek MISC_FLAGS, machineReadable} ptr :: IO CBool)) + <*> (toBool <$> + (#{peek MISC_FLAGS, internalCounters} ptr :: IO CBool)) <*> #{peek MISC_FLAGS, linkerMemBase} ptr getDebugFlags :: IO DebugFlags diff --git a/GHC/Read.hs b/GHC/Read.hs --- a/GHC/Read.hs +++ b/GHC/Read.hs @@ -72,6 +72,7 @@ import GHC.Base import GHC.Arr import GHC.Word +import GHC.List (filter) -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -409,7 +410,7 @@ -- Note [Why readField] -- --- Previousy, the code for automatically deriving Read instance (in +-- Previously, the code for automatically deriving Read instance (in -- typecheck/TcGenDeriv.hs) would generate inline code for parsing fields; -- this, however, turned out to produce massive amounts of intermediate code, -- and produced a considerable performance hit in the code generator. @@ -426,6 +427,7 @@ -- Simple instances of Read -------------------------------------------------------------- +-- | @since 2.01 deriving instance Read GeneralCategory -- | @since 2.01 @@ -475,6 +477,7 @@ readListPrec = readListPrecDefault readList = readListDefault +-- | @since 4.11.0.0 deriving instance Read a => Read (NonEmpty a) -------------------------------------------------------------- @@ -613,6 +616,19 @@ readPrec = readNumber convertInt readListPrec = readListPrecDefault readList = readListDefault + + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (fromInteger n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#else +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (Natural n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#endif -- | @since 2.01 instance Read Float where diff --git a/GHC/Real.hs b/GHC/Real.hs --- a/GHC/Real.hs +++ b/GHC/Real.hs @@ -20,12 +20,16 @@ module GHC.Real where +#include "MachDeps.h" + import GHC.Base import GHC.Num import GHC.List import GHC.Enum import GHC.Show -import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException, ratioZeroDenomException ) +import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException + , underflowException + , ratioZeroDenomException ) #if defined(OPTIMISE_INTEGER_GCD_LCM) # if defined(MIN_VERSION_integer_gmp) @@ -61,12 +65,21 @@ overflowError :: a overflowError = raise# overflowException +{-# NOINLINE underflowError #-} +underflowError :: a +underflowError = raise# underflowException + + -------------------------------------------------------------- -- The Ratio and Rational types -------------------------------------------------------------- -- | Rational numbers, with numerator and denominator of some 'Integral' type. -data Ratio a = !a :% !a deriving (Eq) +-- +-- Note that `Ratio`'s instances inherit the deficiencies from the type +-- parameter's. For example, @Ratio Natural@'s 'Num' instance has similar +-- problems to `Numeric.Natural.Natural`'s. +data Ratio a = !a :% !a deriving Eq -- ^ @since 2.01 -- | Arbitrary-precision rational numbers, represented as a ratio of -- two 'Integer' values. A rational number may be constructed using @@ -122,6 +135,19 @@ toRational :: a -> Rational -- | Integral numbers, supporting integer division. +-- +-- The Haskell Report defines no laws for 'Integral'. However, 'Integral' +-- instances are customarily expected to define a Euclidean domain and have the +-- following properties for the 'div'/'mod' and 'quot'/'rem' pairs, given +-- suitable Euclidean functions @f@ and @g@: +-- +-- * @x@ = @y * quot x y + rem x y@ with @rem x y@ = @fromInteger 0@ or +-- @g (rem x y)@ < @g y@ +-- * @x@ = @y * div x y + mod x y@ with @mod x y@ = @fromInteger 0@ or +-- @f (mod x y)@ < @f y@ +-- +-- An example of a suitable Euclidean function, for `Integer`'s instance, is +-- 'abs'. class (Real a, Enum a) => Integral a where -- | integer division truncated toward zero quot :: a -> a -> a @@ -155,6 +181,16 @@ where qr@(q,r) = quotRem n d -- | Fractional numbers, supporting real division. +-- +-- The Haskell Report defines no laws for 'Fractional'. However, '(+)' and +-- '(*)' are customarily expected to define a division ring and have the +-- following properties: +-- +-- [__'recip' gives the multiplicative inverse__]: +-- @x * recip x@ = @recip x * x@ = @fromInteger 1@ +-- +-- Note that it /isn't/ customarily expected that a type instance of +-- 'Fractional' implement a field. However, all instances in 'base' do. class (Num a) => Fractional a where {-# MINIMAL fromRational, (recip | (/)) #-} @@ -216,10 +252,19 @@ -- These 'numeric' enumerations come straight from the Report numericEnumFrom :: (Fractional a) => a -> [a] -numericEnumFrom n = n `seq` (n : numericEnumFrom (n + 1)) +numericEnumFrom n = go 0 + where + -- See Note [Numeric Stability of Enumerating Floating Numbers] + go !k = let !n' = n + k + in n' : go (k + 1) numericEnumFromThen :: (Fractional a) => a -> a -> [a] -numericEnumFromThen n m = n `seq` m `seq` (n : numericEnumFromThen m (m+m-n)) +numericEnumFromThen n m = go 0 + where + step = m - n + -- See Note [Numeric Stability of Enumerating Floating Numbers] + go !k = let !n' = n + k * step + in n' : go (k + 1) numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a] numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n) @@ -232,6 +277,49 @@ predicate | e2 >= e1 = (<= e3 + mid) | otherwise = (>= e3 + mid) +{- Note [Numeric Stability of Enumerating Floating Numbers] +----------------------------------------------------------- +When enumerate floating numbers, we could add the increment to the last number +at every run (as what we did previously): + + numericEnumFrom n = n `seq` (n : numericEnumFrom (n + 1)) + +This approach is concise and really fast, only needs an addition operation. +However when a floating number is large enough, for `n`, `n` and `n+1` will +have the same binary representation. For example (all number has type +`Double`): + + 9007199254740990 is: 0x433ffffffffffffe + 9007199254740990 + 1 is: 0x433fffffffffffff + (9007199254740990 + 1) + 1 is: 0x4340000000000000 + ((9007199254740990 + 1) + 1) + 1 is: 0x4340000000000000 + +When we evaluate ([9007199254740990..9007199254740991] :: Double), we would +never reach the condition in `numericEnumFromTo` + + 9007199254740990 + 1 + 1 + ... > 9007199254740991 + 1/2 + +We would fall into infinite loop (as reported in Trac #15081). + +To remedy the situation, we record the number of `1` that needed to be added +to the start number, rather than increasing `1` at every time. This approach +can improvement the numeric stability greatly at the cost of a multiplication. + +Furthermore, we use the type of the enumerated number, `Fractional a => a`, +as the type of multiplier. In rare situations, the multiplier could be very +large and will lead to the enumeration to infinite loop, too, which should +be very rare. Consider the following example: + + [1..9007199254740994] + +We could fix that by using an Integer as multiplier but we don't do that. +The benchmark on T7954.hs shows that this approach leads to significant +degeneration on performance (33% increase allocation and 300% increase on +elapsed time). + +See Trac #15081 and Phab:D4650 for the related discussion about this problem. +-} + -------------------------------------------------------------- -- Instances for Int -------------------------------------------------------------- @@ -324,6 +412,18 @@ instance Real Integer where toRational x = x :% 1 +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Real Natural where + toRational (NatS# w) = toRational (W# w) + toRational (NatJ# bn) = toRational (Jp# bn) +#else +-- | @since 4.8.0.0 +instance Real Natural where + toRational (Natural a) = toRational a + {-# INLINE toRational #-} +#endif + -- Note [Integer division constant folding] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -366,6 +466,39 @@ n `quotRem` d = case n `quotRemInteger` d of (# q, r #) -> (q, r) +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Integral Natural where + toInteger = naturalToInteger + + divMod = quotRemNatural + div = quotNatural + mod = remNatural + + quotRem = quotRemNatural + quot = quotNatural + rem = remNatural +#else +-- | @since 4.8.0.0 +instance Integral Natural where + quot (Natural a) (Natural b) = Natural (quot a b) + {-# INLINE quot #-} + rem (Natural a) (Natural b) = Natural (rem a b) + {-# INLINE rem #-} + div (Natural a) (Natural b) = Natural (div a b) + {-# INLINE div #-} + mod (Natural a) (Natural b) = Natural (mod a b) + {-# INLINE mod #-} + divMod (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = divMod a b + {-# INLINE divMod #-} + quotRem (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = quotRem a b + {-# INLINE quotRem #-} + toInteger (Natural a) = a + {-# INLINE toInteger #-} +#endif + -------------------------------------------------------------- -- Instances for @Ratio@ -------------------------------------------------------------- @@ -454,6 +587,17 @@ "fromIntegral/Word->Word" fromIntegral = id :: Word -> Word #-} +{-# RULES +"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural +"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer +"fromIntegral/Natural->Word" fromIntegral = naturalToWord + #-} + +{-# RULES +"fromIntegral/Word->Natural" fromIntegral = wordToNatural +"fromIntegral/Int->Natural" fromIntegral = intToNatural + #-} + -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b {-# NOINLINE [1] realToFrac #-} @@ -646,6 +790,8 @@ "gcd/Int->Int->Int" gcd = gcdInt' "gcd/Integer->Integer->Integer" gcd = gcdInteger "lcm/Integer->Integer->Integer" lcm = lcmInteger +"gcd/Natural->Natural->Natural" gcd = gcdNatural +"lcm/Natural->Natural->Natural" lcm = lcmNatural #-} gcdInt' :: Int -> Int -> Int diff --git a/GHC/ResponseFile.hs b/GHC/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/GHC/ResponseFile.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ResponseFile +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : portable +-- +-- GCC style response files. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +-- Migrated from Haddock. + +module GHC.ResponseFile ( + getArgsWithResponseFiles, + unescapeArgs, + escapeArgs, + expandResponse + ) where + +import Control.Exception +import Data.Char (isSpace) +import Data.Foldable (foldl') +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--'two' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechasnism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\"" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like '@foo' will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/GHC/ST.hs b/GHC/ST.hs --- a/GHC/ST.hs +++ b/GHC/ST.hs @@ -18,7 +18,7 @@ module GHC.ST ( ST(..), STret(..), STRep, - fixST, runST, + runST, -- * Unsafe functions liftST, unsafeInterleaveST, unsafeDupableInterleaveST @@ -92,8 +92,7 @@ data STret s a = STret (State# s) a --- liftST is useful when we want a lifted result from an ST computation. See --- fixST below. +-- liftST is useful when we want a lifted result from an ST computation. liftST :: ST s a -> State# s -> STret s a liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r @@ -125,16 +124,6 @@ in (# s, r #) ) - --- | Allow the result of a state transformer computation to be used (lazily) --- inside the computation. --- Note that if @f@ is strict, @'fixST' f = _|_@. -fixST :: (a -> ST s a) -> ST s a -fixST k = ST $ \ s -> - let ans = liftST (k r) s - STret _ r = ans - in - case ans of STret s' x -> (# s', x #) -- | @since 2.01 instance Show (ST s a) where diff --git a/GHC/Show.hs b/GHC/Show.hs --- a/GHC/Show.hs +++ b/GHC/Show.hs @@ -165,6 +165,7 @@ -- Simple Instances -------------------------------------------------------------- +-- | @since 2.01 deriving instance Show () -- | @since 2.01 @@ -174,7 +175,10 @@ {-# SPECIALISE instance Show [Int] #-} showsPrec _ = showList +-- | @since 2.01 deriving instance Show Bool + +-- | @since 2.01 deriving instance Show Ordering -- | @since 2.01 @@ -199,7 +203,10 @@ c# -> showWord (w# `quotWord#` 10##) (C# c# : cs) +-- | @since 2.01 deriving instance Show a => Show (Maybe a) + +-- | @since 4.11.0.0 deriving instance Show a => Show (NonEmpty a) -- | @since 2.01 @@ -219,6 +226,7 @@ instance Show CallStack where showsPrec _ = shows . getCallStack +-- | @since 4.9.0.0 deriving instance Show SrcLoc -------------------------------------------------------------- @@ -471,6 +479,13 @@ | otherwise = integerToString n r showList = showList__ (showsPrec 0) +-- | @since 4.8.0.0 +instance Show Natural where +#if defined(MIN_VERSION_integer_gmp) + showsPrec p (NatS# w#) = showsPrec p (W# w#) +#endif + showsPrec p i = showsPrec p (naturalToInteger i) + -- Divide and conquer implementation of string conversion integerToString :: Integer -> String -> String integerToString n0 cs0 @@ -581,7 +596,14 @@ . showString " " . showsPrec 11 q +-- | @since 4.11.0.0 deriving instance Show RuntimeRep + +-- | @since 4.11.0.0 deriving instance Show VecCount + +-- | @since 4.11.0.0 deriving instance Show VecElem + +-- | @since 4.11.0.0 deriving instance Show TypeLitSort diff --git a/GHC/Stable.hs b/GHC/Stable.hs --- a/GHC/Stable.hs +++ b/GHC/Stable.hs @@ -101,7 +101,7 @@ castPtrToStablePtr :: Ptr () -> StablePtr a castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerce# a) --- | @since 2.1 +-- | @since 2.01 instance Eq (StablePtr a) where (StablePtr sp1) == (StablePtr sp2) = case eqStablePtr# sp1 sp2 of diff --git a/GHC/StableName.hs b/GHC/StableName.hs new file mode 100644 --- /dev/null +++ b/GHC/StableName.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Mem.StableName +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Stable names are a way of performing fast (O(1)), not-quite-exact +-- comparison between objects. +-- +-- Stable names solve the following problem: suppose you want to build +-- a hash table with Haskell objects as keys, but you want to use +-- pointer equality for comparison; maybe because the keys are large +-- and hashing would be slow, or perhaps because the keys are infinite +-- in size. We can\'t build a hash table using the address of the +-- object as the key, because objects get moved around by the garbage +-- collector, meaning a re-hash would be necessary after every garbage +-- collection. +-- +------------------------------------------------------------------------------- + +module GHC.StableName ( + -- * Stable Names + StableName (..), + makeStableName, + hashStableName, + eqStableName + ) where + +import GHC.IO ( IO(..) ) +import GHC.Base ( Int(..), StableName#, makeStableName# + , eqStableName#, stableNameToInt# ) + +----------------------------------------------------------------------------- +-- Stable Names + +{-| + An abstract name for an object, that supports equality and hashing. + + Stable names have the following property: + + * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ + then @sn1@ and @sn2@ were created by calls to @makeStableName@ on + the same object. + + The reverse is not necessarily true: if two stable names are not + equal, then the objects they name may still be equal. Note in particular + that `makeStableName` may return a different `StableName` after an + object is evaluated. + + Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), + but differ in the following ways: + + * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. + Stable names are reclaimed by the runtime system when they are no + longer needed. + + * There is no @deRefStableName@ operation. You can\'t get back from + a stable name to the original Haskell object. The reason for + this is that the existence of a stable name for an object does not + guarantee the existence of the object itself; it can still be garbage + collected. +-} + +data StableName a = StableName (StableName# a) + +-- | Makes a 'StableName' for an arbitrary object. The object passed as +-- the first argument is not evaluated by 'makeStableName'. +makeStableName :: a -> IO (StableName a) +makeStableName a = IO $ \ s -> + case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) + +-- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not +-- necessarily unique; several 'StableName's may map to the same 'Int' +-- (in practice however, the chances of this are small, so the result +-- of 'hashStableName' makes a good hash key). +hashStableName :: StableName a -> Int +hashStableName (StableName sn) = I# (stableNameToInt# sn) + +-- | @since 2.01 +instance Eq (StableName a) where + (StableName sn1) == (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True + +-- | Equality on 'StableName' that does not require that the types of +-- the arguments match. +-- +-- @since 4.7.0.0 +eqStableName :: StableName a -> StableName b -> Bool +eqStableName (StableName sn1) (StableName sn2) = + case eqStableName# sn1 sn2 of + 0# -> False + _ -> True + -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to + -- use it for implementing observable sharing. + diff --git a/GHC/Stack/Types.hs b/GHC/Stack/Types.hs --- a/GHC/Stack/Types.hs +++ b/GHC/Stack/Types.hs @@ -53,6 +53,7 @@ -- Make implicit dependency known to build system import GHC.Tuple () import GHC.Integer () +import GHC.Natural () ---------------------------------------------------------------------- -- Explicit call-stacks built via ImplicitParams @@ -215,4 +216,4 @@ , srcLocStartCol :: Int , srcLocEndLine :: Int , srcLocEndCol :: Int - } deriving Eq + } deriving Eq -- ^ @since 4.9.0.0 diff --git a/GHC/StaticPtr.hs b/GHC/StaticPtr.hs --- a/GHC/StaticPtr.hs +++ b/GHC/StaticPtr.hs @@ -115,7 +115,7 @@ -- @(Line, Column)@ pair. , spInfoSrcLoc :: (Int, Int) } - deriving (Show) + deriving Show -- ^ @since 4.8.0.0 -- | 'StaticPtrInfo' of the given 'StaticPtr'. staticPtrInfo :: StaticPtr a -> StaticPtrInfo diff --git a/GHC/Stats.hsc b/GHC/Stats.hsc --- a/GHC/Stats.hsc +++ b/GHC/Stats.hsc @@ -56,7 +56,8 @@ , major_gcs :: Word32 -- | Total bytes allocated , allocated_bytes :: Word64 - -- | Maximum live data (including large objects + compact regions) + -- | Maximum live data (including large objects + compact regions) in the + -- heap. Updated after a major GC. , max_live_bytes :: Word64 -- | Maximum live data in large objects , max_large_objects_bytes :: Word64 @@ -83,6 +84,12 @@ -- (we use signed values here because due to inaccuracies in timers -- the values can occasionally go slightly negative) + -- | Total CPU time used by the init phase + -- @since 4.12.0.0 + , init_cpu_ns :: RtsTime + -- | Total elapsed time used by the init phase + -- @since 4.12.0.0 + , init_elapsed_ns :: RtsTime -- | Total CPU time used by the mutator , mutator_cpu_ns :: RtsTime -- | Total elapsed time used by the mutator @@ -98,7 +105,9 @@ -- | Details about the most recent GC , gc :: GCDetails - } deriving (Read, Show) + } deriving ( Read -- ^ @since 4.10.0.0 + , Show -- ^ @since 4.10.0.0 + ) -- -- | Statistics about a single GC. This is a mirror of the C @struct @@ -112,7 +121,9 @@ , gcdetails_threads :: Word32 -- | Number of bytes allocated since the previous GC , gcdetails_allocated_bytes :: Word64 - -- | Total amount of live data in the heap (incliudes large + compact data) + -- | Total amount of live data in the heap (incliudes large + compact data). + -- Updated after every GC. Data in uncollected generations (in minor GCs) + -- are considered live. , gcdetails_live_bytes :: Word64 -- | Total amount of live data in large objects , gcdetails_large_objects_bytes :: Word64 @@ -135,7 +146,9 @@ , gcdetails_cpu_ns :: RtsTime -- | The time elapsed during GC itself , gcdetails_elapsed_ns :: RtsTime - } deriving (Read, Show) + } deriving ( Read -- ^ @since 4.10.0.0 + , Show -- ^ @since 4.10.0.0 + ) -- | Time values from the RTS, using a fixed resolution of nanoseconds. type RtsTime = Int64 @@ -171,6 +184,8 @@ (# peek RTSStats, cumulative_par_max_copied_bytes) p cumulative_par_balanced_copied_bytes <- (# peek RTSStats, cumulative_par_balanced_copied_bytes) p + init_cpu_ns <- (# peek RTSStats, init_cpu_ns) p + init_elapsed_ns <- (# peek RTSStats, init_elapsed_ns) p mutator_cpu_ns <- (# peek RTSStats, mutator_cpu_ns) p mutator_elapsed_ns <- (# peek RTSStats, mutator_elapsed_ns) p gc_cpu_ns <- (# peek RTSStats, gc_cpu_ns) p diff --git a/GHC/TypeNats.hs b/GHC/TypeNats.hs --- a/GHC/TypeNats.hs +++ b/GHC/TypeNats.hs @@ -3,6 +3,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/GHC/Unicode.hs b/GHC/Unicode.hs --- a/GHC/Unicode.hs +++ b/GHC/Unicode.hs @@ -7,7 +7,7 @@ -- Module : GHC.Unicode -- Copyright : (c) The University of Glasgow, 2003 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC extensions) @@ -129,7 +129,13 @@ | Surrogate -- ^ Cs: Other, Surrogate | PrivateUse -- ^ Co: Other, Private Use | NotAssigned -- ^ Cn: Other, Not Assigned - deriving (Show, Eq, Ord, Enum, Bounded, Ix) + deriving ( Show -- ^ @since 2.01 + , Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Enum -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Ix -- ^ @since 2.01 + ) -- | The Unicode general category of the character. This relies on the -- 'Enum' instance of 'GeneralCategory', which must remain in the @@ -214,11 +220,12 @@ -- This function is equivalent to 'Data.Char.isLetter'. isAlpha :: Char -> Bool --- | Selects alphabetic or numeric digit Unicode characters. +-- | Selects alphabetic or numeric Unicode characters. -- --- Note that numeric digits outside the ASCII range are selected by this --- function but not by 'isDigit'. Such digits may be part of identifiers --- but are not used by the printer and reader to represent numbers. +-- Note that numeric digits outside the ASCII range, as well as numeric +-- characters which aren't digits, are selected by this function but not by +-- 'isDigit'. Such characters may be part of identifiers but are not used by +-- the printer and reader to represent numbers. isAlphaNum :: Char -> Bool -- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@. @@ -394,4 +401,3 @@ foreign import ccall unsafe "u_gencat" wgencat :: Int -> Int - diff --git a/GHC/Weak.hs b/GHC/Weak.hs --- a/GHC/Weak.hs +++ b/GHC/Weak.hs @@ -149,8 +149,9 @@ 0# -> (# s, () #) _ -> let !m' = m -# 1# in case indexArray# arr m' of { (# io #) -> - case io s of { s' -> - unIO (go m') s' + case catch# (\p -> (# io p, () #)) + (\_ s'' -> (# s'', () #)) s of { + (# s', _ #) -> unIO (go m') s' }} in go n diff --git a/GHC/Word.hs b/GHC/Word.hs --- a/GHC/Word.hs +++ b/GHC/Word.hs @@ -972,3 +972,33 @@ byteSwap64 :: Word64 -> Word64 byteSwap64 (W64# w#) = W64# (byteSwap# w#) #endif + +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Word8" + fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord +"fromIntegral/Natural->Word16" + fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord +"fromIntegral/Natural->Word32" + fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord + #-} + +{-# RULES +"fromIntegral/Word8->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) +"fromIntegral/Word16->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) +"fromIntegral/Word32->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 +{-# RULES +"fromIntegral/Natural->Word64" + fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord +"fromIntegral/Word64->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) + #-} +#endif diff --git a/System/Environment/Blank.hsc b/System/Environment/Blank.hsc --- a/System/Environment/Blank.hsc +++ b/System/Environment/Blank.hsc @@ -18,19 +18,15 @@ -- -- The matrix of platforms that: -- --- * support putenv("FOO") to unset environment variables, --- * support putenv("FOO=") to unset environment variables or set them +-- * support @putenv("FOO")@ to unset environment variables, +-- * support @putenv("FOO=")@ to unset environment variables or set them -- to blank values, --- * support unsetenv to unset environment variables, --- * support setenv to set environment variables, +-- * support @unsetenv@ to unset environment variables, +-- * support @setenv@ to set environment variables, -- * etc. -- --- is very complicated. I think AIX is screwed, but we don't support it. --- The whole situation with setenv(3), unsetenv(3), and putenv(3) is not --- good. Even mingw32 adds its own crap to the pile, but luckily, we can --- just use Windows' native environment functions to sidestep the issue. --- --- #12494 +-- is very complicated. Some platforms don't support unsetting of environment +-- variables at all. -- ----------------------------------------------------------------------------- @@ -87,7 +83,7 @@ throwInvalidArgument from = throwIO (mkIOError InvalidArgument from Nothing Nothing) --- | `System.Environment.lookupEnv`. +-- | Similar to 'System.Environment.lookupEnv'. getEnv :: String -> IO (Maybe String) #ifdef mingw32_HOST_OS getEnv = (<$> getEnvironment) . lookup @@ -102,8 +98,8 @@ IO String {- ^ variable value or fallback value -} getEnvDefault name fallback = fromMaybe fallback <$> getEnv name --- | Like `System.Environment.setEnv`, but allows blank environment values --- and mimics the function signature of `System.Posix.Env.setEnv` from the +-- | Like 'System.Environment.setEnv', but allows blank environment values +-- and mimics the function signature of 'System.Posix.Env.setEnv' from the -- @unix@ package. setEnv :: String {- ^ variable name -} -> @@ -144,8 +140,9 @@ c_setenv :: CString -> CString -> CInt -> IO CInt #endif --- | Like `System.Environment.unsetEnv`, but allows for the removal of --- blank environment variables. +-- | Like 'System.Environment.unsetEnv', but allows for the removal of +-- blank environment variables. May throw an exception if the underlying +-- platform doesn't support unsetting of environment variables. unsetEnv :: String -> IO () #if defined(mingw32_HOST_OS) unsetEnv key = withCWString key $ \k -> do diff --git a/System/Environment/ExecutablePath.hsc b/System/Environment/ExecutablePath.hsc --- a/System/Environment/ExecutablePath.hsc +++ b/System/Environment/ExecutablePath.hsc @@ -40,6 +40,7 @@ import Foreign.Marshal.Array import Foreign.Ptr #include +#include #else import Foreign.C import Foreign.Marshal.Alloc @@ -169,7 +170,7 @@ getFinalPath :: FilePath -> IO FilePath getFinalPath path = withCWString path $ \s -> bracket (createFile s) c_closeHandle $ \h -> do - let invalid = h == wordPtrToPtr (#const INVALID_HANDLE_VALUE) + let invalid = h == wordPtrToPtr (#const (intptr_t)INVALID_HANDLE_VALUE) if invalid then pure path else go h bufSize where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do diff --git a/System/Mem/StableName.hs b/System/Mem/StableName.hs --- a/System/Mem/StableName.hs +++ b/System/Mem/StableName.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -35,72 +32,4 @@ eqStableName ) where -import GHC.IO ( IO(..) ) -import GHC.Base ( Int(..), StableName#, makeStableName# - , eqStableName#, stableNameToInt# ) - ------------------------------------------------------------------------------ --- Stable Names - -{-| - An abstract name for an object, that supports equality and hashing. - - Stable names have the following property: - - * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ - then @sn1@ and @sn2@ were created by calls to @makeStableName@ on - the same object. - - The reverse is not necessarily true: if two stable names are not - equal, then the objects they name may still be equal. Note in particular - that `makeStableName` may return a different `StableName` after an - object is evaluated. - - Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), - but differ in the following ways: - - * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. - Stable names are reclaimed by the runtime system when they are no - longer needed. - - * There is no @deRefStableName@ operation. You can\'t get back from - a stable name to the original Haskell object. The reason for - this is that the existence of a stable name for an object does not - guarantee the existence of the object itself; it can still be garbage - collected. --} - -data StableName a = StableName (StableName# a) - --- | Makes a 'StableName' for an arbitrary object. The object passed as --- the first argument is not evaluated by 'makeStableName'. -makeStableName :: a -> IO (StableName a) -makeStableName a = IO $ \ s -> - case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) - --- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not --- necessarily unique; several 'StableName's may map to the same 'Int' --- (in practice however, the chances of this are small, so the result --- of 'hashStableName' makes a good hash key). -hashStableName :: StableName a -> Int -hashStableName (StableName sn) = I# (stableNameToInt# sn) - --- | @since 2.01 -instance Eq (StableName a) where - (StableName sn1) == (StableName sn2) = - case eqStableName# sn1 sn2 of - 0# -> False - _ -> True - --- | Equality on 'StableName' that does not require that the types of --- the arguments match. --- --- @since 4.7.0.0 -eqStableName :: StableName a -> StableName b -> Bool -eqStableName (StableName sn1) (StableName sn2) = - case eqStableName# sn1 sn2 of - 0# -> False - _ -> True - -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to - -- use it for implementing observable sharing. - +import GHC.StableName diff --git a/System/Timeout.hs b/System/Timeout.hs --- a/System/Timeout.hs +++ b/System/Timeout.hs @@ -35,9 +35,9 @@ -- interrupt the running IO computation when the timeout has -- expired. -newtype Timeout = Timeout Unique deriving (Eq) +newtype Timeout = Timeout Unique deriving Eq -- ^ @since 4.0 --- | @since 3.0 +-- | @since 4.0 instance Show Timeout where show _ = "<>" diff --git a/Text/ParserCombinators/ReadP.hs b/Text/ParserCombinators/ReadP.hs --- a/Text/ParserCombinators/ReadP.hs +++ b/Text/ParserCombinators/ReadP.hs @@ -100,7 +100,7 @@ | Fail | Result a (P a) | Final [(a,String)] -- invariant: list is non-empty! - deriving Functor + deriving Functor -- ^ @since 4.8.0.0 -- Monad, MonadPlus diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs --- a/Text/Read/Lex.hs +++ b/Text/Read/Lex.hs @@ -68,15 +68,19 @@ | Symbol String -- ^ Haskell symbol, e.g. @>>@, @:%@ | Number Number -- ^ @since 4.6.0.0 | EOF - deriving (Eq, Show) + deriving ( Eq -- ^ @since 2.01 + , Show -- ^ @since 2.01 + ) --- | @since 4.7.0.0 +-- | @since 4.6.0.0 data Number = MkNumber Int -- Base Digits -- Integral part | MkDecimal Digits -- Integral part (Maybe Digits) -- Fractional part (Maybe Integer) -- Exponent - deriving (Eq, Show) + deriving ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.6.0.0 + ) -- | @since 4.5.1.0 numberToInteger :: Number -> Maybe Integer diff --git a/Type/Reflection/Unsafe.hs b/Type/Reflection/Unsafe.hs --- a/Type/Reflection/Unsafe.hs +++ b/Type/Reflection/Unsafe.hs @@ -12,7 +12,7 @@ -- type representations. -- ----------------------------------------------------------------------------- -{-# LANGUAGE TypeInType, ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds, DataKinds, ScopedTypeVariables #-} module Type.Reflection.Unsafe ( -- * Type representations diff --git a/Unsafe/Coerce.hs b/Unsafe/Coerce.hs --- a/Unsafe/Coerce.hs +++ b/Unsafe/Coerce.hs @@ -32,6 +32,7 @@ module Unsafe.Coerce (unsafeCoerce) where import GHC.Integer () -- for build ordering +import GHC.Natural () -- for build ordering import GHC.Prim (unsafeCoerce#) local_id :: a -> a diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,6 +1,7 @@ cabal-version: 2.2 name: base -version: 4.11.1.0 +version: 4.12.0.0 +-- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause license-file: LICENSE @@ -8,11 +9,11 @@ bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/base synopsis: Basic libraries category: Prelude +build-type: Configure description: - This package contains the "Prelude" and its support libraries, + This package contains the Standard Haskell "Prelude" and its support libraries, and a large collection of useful libraries ranging from data structures to parsing combinators and debugging utilities. -build-type: Configure extra-tmp-files: autom4te.cache @@ -35,6 +36,7 @@ include/HsBaseConfig.h.in include/ieee-flpt.h include/md5.h + include/fs.h install-sh source-repository head @@ -93,17 +95,17 @@ UnliftedFFITypes Unsafe - build-depends: rts == 1.0.*, ghc-prim == 0.5.* + build-depends: rts == 1.0, ghc-prim ^>= 0.5.3 -- sanity-check to ensure exactly one flag is set if !((flag(integer-gmp) && !flag(integer-simple)) || (!flag(integer-gmp) && flag(integer-simple))) build-depends: invalid-cabal-flag-settings<0 if flag(integer-simple) - build-depends: integer-simple >= 0.1.1 && < 0.2 + build-depends: integer-simple ^>= 0.1.1 if flag(integer-gmp) - build-depends: integer-gmp >= 1.0 && < 1.1 + build-depends: integer-gmp ^>= 1.0.1 cpp-options: -DOPTIMISE_INTEGER_GCD_LCM exposed-modules: @@ -147,6 +149,7 @@ Data.Function Data.Functor Data.Functor.Classes + Data.Functor.Contravariant Data.Functor.Compose Data.Functor.Const Data.Functor.Identity @@ -216,6 +219,7 @@ GHC.Environment GHC.Err GHC.Exception + GHC.Exception.Type GHC.ExecutionStack GHC.ExecutionStack.Internal GHC.Exts @@ -255,24 +259,26 @@ GHC.IORef GHC.Int GHC.List + GHC.Maybe GHC.MVar GHC.Natural GHC.Num GHC.OldList GHC.OverloadedLabels - GHC.PArr GHC.Pack GHC.Profiling GHC.Ptr GHC.Read GHC.Real GHC.Records + GHC.ResponseFile GHC.RTS.Flags GHC.ST GHC.StaticPtr GHC.STRef GHC.Show GHC.Stable + GHC.StableName GHC.Stack GHC.Stack.CCS GHC.Stack.Types @@ -337,6 +343,7 @@ cbits/md5.c cbits/primFloat.c cbits/sysconf.c + cbits/fs.c cmm-sources: cbits/CastFloatWord.cmm @@ -393,3 +400,6 @@ -- We need to set the unit id to base (without a version number) -- as it's magic. ghc-options: -this-unit-id base + + -- Make sure we don't accidentally regress into anti-patterns + ghc-options: -Wcompat -Wnoncanonical-monad-instances diff --git a/cbits/CastFloatWord.cmm b/cbits/CastFloatWord.cmm new file mode 100644 --- /dev/null +++ b/cbits/CastFloatWord.cmm @@ -0,0 +1,69 @@ +#include "Cmm.h" +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 64 +#define DOUBLE_SIZE_WDS 1 +#else +#define DOUBLE_SIZE_WDS 2 +#endif + +stg_word64ToDoublezh(I64 w) +{ + D_ d; + P_ ptr; + + STK_CHK_GEN_N (DOUBLE_SIZE_WDS); + + reserve DOUBLE_SIZE_WDS = ptr { + I64[ptr] = w; + d = D_[ptr]; + } + + return (d); +} + +stg_doubleToWord64zh(D_ d) +{ + I64 w; + P_ ptr; + + STK_CHK_GEN_N (DOUBLE_SIZE_WDS); + + reserve DOUBLE_SIZE_WDS = ptr { + D_[ptr] = d; + w = I64[ptr]; + } + + return (w); +} + +stg_word32ToFloatzh(W_ w) +{ + F_ f; + P_ ptr; + + STK_CHK_GEN_N (1); + + reserve 1 = ptr { + I32[ptr] = %lobits32(w); + f = F_[ptr]; + } + + return (f); +} + +stg_floatToWord32zh(F_ f) +{ + W_ w; + P_ ptr; + + STK_CHK_GEN_N (1); + + reserve 1 = ptr { + F_[ptr] = f; + w = TO_W_(I32[ptr]); + } + + return (w); +} + diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c --- a/cbits/Win32Utils.c +++ b/cbits/Win32Utils.c @@ -9,6 +9,8 @@ #include "HsBase.h" #include #include +/* Using Secure APIs */ +#define MINGW_HAS_SECURE_API 1 #include #include diff --git a/cbits/fs.c b/cbits/fs.c new file mode 100644 --- /dev/null +++ b/cbits/fs.c @@ -0,0 +1,293 @@ +/* ----------------------------------------------------------------------------- + * + * (c) Tamar Christina 2018 + * + * Windows I/O routines for file opening. + * + * NOTE: Only modify this file in utils/fs/ and rerun configure. Do not edit + * this file in any other directory as it will be overwritten. + * + * ---------------------------------------------------------------------------*/ +#include "fs.h" +#include + +#if defined(_WIN32) + +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +/* This function converts Windows paths between namespaces. More specifically + It converts an explorer style path into a NT or Win32 namespace. + This has several caveats but they are caviats that are native to Windows and + not POSIX. See + https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx. + Anything else such as raw device paths we leave untouched. The main benefit + of doing any of this is that we can break the MAX_PATH restriction and also + access raw handles that we couldn't before. */ +static wchar_t* __hs_create_device_name (const wchar_t* filename) { + const wchar_t* win32_dev_namespace = L"\\\\.\\"; + const wchar_t* win32_file_namespace = L"\\\\?\\"; + const wchar_t* nt_device_namespace = L"\\Device\\"; + const wchar_t* unc_prefix = L"UNC\\"; + const wchar_t* network_share = L"\\\\"; + + wchar_t* result = _wcsdup (filename); + wchar_t ns[10] = {0}; + + /* If the file is already in a native namespace don't change it. */ + if ( wcsncmp (win32_dev_namespace , filename, 4) == 0 + || wcsncmp (win32_file_namespace, filename, 4) == 0 + || wcsncmp (nt_device_namespace , filename, 8) == 0) + return result; + + /* Since we're using the lower level APIs we must normalize slashes now. The + Win32 API layer will no longer convert '/' into '\\' for us. */ + for (size_t i = 0; i < wcslen (result); i++) + { + if (result[i] == L'/') + result[i] = L'\\'; + } + + /* Now resolve any . and .. in the path or subsequent API calls may fail since + Win32 will no longer resolve them. */ + DWORD nResult = GetFullPathNameW (result, 0, NULL, NULL) + 1; + wchar_t *temp = _wcsdup (result); + result = malloc (nResult * sizeof (wchar_t)); + if (GetFullPathNameW (temp, nResult, result, NULL) == 0) + { + goto cleanup; + } + + free (temp); + + if (wcsncmp (network_share, result, 2) == 0) + { + if (swprintf (ns, 10, L"%ls%ls", win32_file_namespace, unc_prefix) <= 0) + { + goto cleanup; + } + } + else if (swprintf (ns, 10, L"%ls", win32_file_namespace) <= 0) + { + goto cleanup; + } + + /* Create new string. */ + int bLen = wcslen (result) + wcslen (ns) + 1; + temp = _wcsdup (result); + result = malloc (bLen * sizeof (wchar_t)); + if (swprintf (result, bLen, L"%ls%ls", ns, temp) <= 0) + { + goto cleanup; + } + + free (temp); + + return result; + +cleanup: + free (temp); + free (result); + return NULL; +} + +#define HAS_FLAG(a,b) ((a & b) == b) + +int FS(swopen) (const wchar_t* filename, int oflag, int shflag, int pmode) +{ + /* Construct access mode. */ + DWORD dwDesiredAccess = 0; + if (HAS_FLAG (oflag, _O_RDONLY)) + dwDesiredAccess |= GENERIC_READ | FILE_READ_DATA | FILE_READ_ATTRIBUTES | + FILE_WRITE_ATTRIBUTES;; + if (HAS_FLAG (oflag, _O_RDWR)) + dwDesiredAccess |= GENERIC_WRITE | GENERIC_READ | FILE_READ_DATA | + FILE_WRITE_DATA | FILE_READ_ATTRIBUTES | + FILE_WRITE_ATTRIBUTES; + if (HAS_FLAG (oflag, _O_WRONLY)) + dwDesiredAccess|= GENERIC_WRITE | FILE_WRITE_DATA | + FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES; + + /* Construct shared mode. */ + DWORD dwShareMode = FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE; + if (HAS_FLAG (shflag, _SH_DENYRW)) + dwShareMode &= ~(FILE_SHARE_READ | FILE_SHARE_WRITE); + if (HAS_FLAG (shflag, _SH_DENYWR)) + dwShareMode &= ~FILE_SHARE_WRITE; + if (HAS_FLAG (shflag, _SH_DENYRD)) + dwShareMode &= ~FILE_SHARE_READ; + if (HAS_FLAG (pmode, _S_IWRITE)) + dwShareMode |= FILE_SHARE_READ | FILE_SHARE_WRITE; + if (HAS_FLAG (pmode, _S_IREAD)) + dwShareMode |= FILE_SHARE_READ; + + /* Override access mode with pmode if creating file. */ + if (HAS_FLAG (oflag, _O_CREAT)) + { + if (HAS_FLAG (pmode, _S_IWRITE)) + dwDesiredAccess |= FILE_GENERIC_WRITE; + if (HAS_FLAG (pmode, _S_IREAD)) + dwDesiredAccess |= FILE_GENERIC_READ; + } + + /* Create file disposition. */ + DWORD dwCreationDisposition = OPEN_EXISTING; + if (HAS_FLAG (oflag, _O_CREAT)) + dwCreationDisposition = OPEN_ALWAYS; + if (HAS_FLAG (oflag, (_O_CREAT | _O_EXCL))) + dwCreationDisposition = CREATE_NEW; + if (HAS_FLAG (oflag, _O_TRUNC) && !HAS_FLAG (oflag, _O_CREAT)) + dwCreationDisposition = TRUNCATE_EXISTING; + + /* Set file access attributes. */ + DWORD dwFlagsAndAttributes = FILE_ATTRIBUTE_NORMAL; + if (HAS_FLAG (oflag, _O_RDONLY)) + dwFlagsAndAttributes |= 0; /* No special attribute. */ + if (HAS_FLAG (oflag, (_O_CREAT | _O_TEMPORARY))) + dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE; + if (HAS_FLAG (oflag, (_O_CREAT | _O_SHORT_LIVED))) + dwFlagsAndAttributes |= FILE_ATTRIBUTE_TEMPORARY; + if (HAS_FLAG (oflag, _O_RANDOM)) + dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS; + if (HAS_FLAG (oflag, _O_SEQUENTIAL)) + dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN; + /* Flag is only valid on it's own. */ + if (dwFlagsAndAttributes != FILE_ATTRIBUTE_NORMAL) + dwFlagsAndAttributes &= ~FILE_ATTRIBUTE_NORMAL; + + /* Set security attributes. */ + SECURITY_ATTRIBUTES securityAttributes; + ZeroMemory (&securityAttributes, sizeof(SECURITY_ATTRIBUTES)); + securityAttributes.bInheritHandle = !(oflag & _O_NOINHERIT); + securityAttributes.lpSecurityDescriptor = NULL; + securityAttributes.nLength = sizeof(SECURITY_ATTRIBUTES); + + wchar_t* _filename = __hs_create_device_name (filename); + if (!_filename) + return -1; + + HANDLE hResult + = CreateFileW (_filename, dwDesiredAccess, dwShareMode, &securityAttributes, + dwCreationDisposition, dwFlagsAndAttributes, NULL); + free (_filename); + if (INVALID_HANDLE_VALUE == hResult) + return -1; + + /* Now we have a Windows handle, we have to convert it to an FD and apply + the remaining flags. */ + const int flag_mask = _O_APPEND | _O_RDONLY | _O_TEXT | _O_WTEXT; + int fd = _open_osfhandle ((intptr_t)hResult, oflag & flag_mask); + if (-1 == fd) + return -1; + + /* Finally we can change the mode to the requested one. */ + const int mode_mask = _O_TEXT | _O_BINARY | _O_U16TEXT | _O_U8TEXT | _O_WTEXT; + if ((oflag & mode_mask) && (-1 == _setmode (fd, oflag & mode_mask))) + return -1; + + return fd; +} + +FILE *FS(fwopen) (const wchar_t* filename, const wchar_t* mode) +{ + int shflag = 0; + int pmode = 0; + int oflag = 0; + + int len = wcslen (mode); + int i; + #define IS_EXT(X) ((i < (len - 1)) && mode[i] == X) + + for (i = 0; i < len; i++) + { + switch (mode[i]) + { + case L'a': + if (IS_EXT (L'+')) + oflag |= _O_RDWR | _O_CREAT | _O_APPEND; + else + oflag |= _O_WRONLY | _O_CREAT | _O_APPEND; + break; + case L'r': + if (IS_EXT (L'+')) + oflag |= _O_RDWR; + else + oflag |= _O_RDONLY; + break; + case L'w': + if (IS_EXT (L'+')) + oflag |= _O_RDWR | _O_CREAT | _O_TRUNC; + else + oflag |= _O_WRONLY | _O_CREAT | _O_TRUNC; + break; + case L'b': + oflag |= _O_BINARY; + break; + case L't': + oflag |= _O_TEXT; + break; + case L'c': + case L'n': + oflag |= 0; + break; + case L'S': + oflag |= _O_SEQUENTIAL; + break; + case L'R': + oflag |= _O_RANDOM; + break; + case L'T': + oflag |= _O_SHORT_LIVED; + break; + case L'D': + oflag |= _O_TEMPORARY; + break; + default: + if (wcsncmp (mode, L"ccs=UNICODE", 11) == 0) + oflag |= _O_WTEXT; + else if (wcsncmp (mode, L"ccs=UTF-8", 9) == 0) + oflag |= _O_U8TEXT; + else if (wcsncmp (mode, L"ccs=UTF-16LE", 12) == 0) + oflag |= _O_U16TEXT; + else continue; + } + } + #undef IS_EXT + + int fd = FS(swopen) (filename, oflag, shflag, pmode); + FILE* file = _wfdopen (fd, mode); + return file; +} + +FILE *FS(fopen) (const char* filename, const char* mode) +{ + size_t len = mbstowcs (NULL, filename, 0); + wchar_t *w_filename = malloc (sizeof (wchar_t) * (len + 1)); + mbstowcs (w_filename, filename, len); + w_filename[len] = L'\0'; + + len = mbstowcs (NULL, mode, 0); + wchar_t *w_mode = malloc (sizeof (wchar_t) * (len + 1)); + mbstowcs (w_mode, mode, len); + w_mode[len] = L'\0'; + + FILE *result = FS(fwopen) (w_filename, w_mode); + free (w_filename); + free (w_mode); + return result; +} +#else +FILE *FS(fopen) (const char* filename, const char* mode) +{ + return fopen (filename, mode); +} +#endif diff --git a/cbits/inputReady.c b/cbits/inputReady.c --- a/cbits/inputReady.c +++ b/cbits/inputReady.c @@ -33,6 +33,10 @@ /* * Returns a timeout suitable to be passed into poll(). * + * If `remaining` contains a fractional milliseconds part that cannot be passed + * to poll(), this function will return the next larger value that can, so + * that the timeout passed to poll() would always be `>= remaining`. + * * If `infinite`, `remaining` is ignored. */ static inline @@ -45,7 +49,11 @@ if (remaining > MSToTime(INT_MAX)) return INT_MAX; - return TimeToMS(remaining); + int remaining_ms = TimeToMS(remaining); + + if (remaining != MSToTime(remaining_ms)) return remaining_ms + 1; + + return remaining_ms; } #if defined(_WIN32) @@ -88,6 +96,11 @@ * Returns a timeout suitable to be passed into WaitForSingleObject() on * Windows. * + * If `remaining` contains a fractional milliseconds part that cannot be passed + * to WaitForSingleObject(), this function will return the next larger value + * that can, so that the timeout passed to WaitForSingleObject() would + * always be `>= remaining`. + * * If `infinite`, `remaining` is ignored. */ static inline @@ -112,7 +125,11 @@ if (remaining >= MSToTime(INFINITE)) return INFINITE - 1; - return (DWORD) TimeToMS(remaining); + DWORD remaining_ms = TimeToMS(remaining); + + if (remaining != MSToTime(remaining_ms)) return remaining_ms + 1; + + return remaining_ms; } #endif @@ -134,7 +151,7 @@ * On error, sets `errno`. */ int -fdReady(int fd, int write, int64_t msecs, int isSock) +fdReady(int fd, bool write, int64_t msecs, bool isSock) { bool infinite = msecs < 0; @@ -150,6 +167,55 @@ Time remaining = MSToTime(msecs); + // Note [Guaranteed syscall time spent] + // + // The implementation ensures that if fdReady() is called with N `msecs`, + // it will not return before an FD-polling syscall *returns* + // with `endTime` having passed. + // + // Consider the following scenario: + // + // 1 int ready = poll(..., msecs); + // 2 if (EINTR happened) { + // 3 Time now = getProcessElapsedTime(); + // 4 if (now >= endTime) return 0; + // 5 remaining = endTime - now; + // 6 } + // + // If `msecs` is 5 seconds, but in line 1 poll() returns with EINTR after + // only 10 ms due to a signal, and if at line 2 the machine starts + // swapping for 10 seconds, then line 4 will return that there's no + // data ready, even though by now there may be data ready now, and we have + // not actually checked after up to `msecs` = 5 seconds whether there's + // data ready as promised. + // + // Why is this important? + // Assume you call the pizza man to bring you a pizza. + // You arrange that you won't pay if he doesn't ring your doorbell + // in under 10 minutes delivery time. + // At 9:58 fdReady() gets woken by EINTR and then your computer swaps + // for 3 seconds. + // At 9:59 the pizza man rings. + // At 10:01 fdReady() will incorrectly tell you that the pizza man hasn't + // rung within 10 minutes, when in fact he has. + // + // If the pizza man is some watchdog service or dead man's switch program, + // this is problematic. + // + // To avoid it, we ensure that in the timeline diagram: + // + // endTime + // | + // time ----+----------+-------+----> + // | | + // syscall starts syscall returns + // + // the "syscall returns" event is always >= the "endTime" time. + // + // In the code this means that we never check whether to `return 0` + // after a `Time now = getProcessElapsedTime();`, and instead always + // let the branch marked [we waited the full msecs] handle that case. + #if !defined(_WIN32) struct pollfd fds[1]; @@ -174,7 +240,7 @@ return 1; // FD has new data if (res == 0 && !infinite && remaining <= MSToTime(INT_MAX)) - return 0; // FD has no new data and we've waited the full msecs + return 0; // FD has no new data and [we waited the full msecs] // Non-exit cases CHECK( ( res < 0 && errno == EINTR ) || // EINTR happened @@ -184,7 +250,6 @@ if (!infinite) { Time now = getProcessElapsedTime(); - if (now >= endTime) return 0; remaining = endTime - now; } } @@ -231,7 +296,7 @@ return 1; // FD has new data if (res == 0 && !infinite && remaining <= MSToTime(INT_MAX)) - return 0; // FD has no new data and we've waited the full msecs + return 0; // FD has no new data and [we waited the full msecs] // Non-exit cases CHECK( ( res < 0 && errno == EINTR ) || // EINTR happened @@ -241,7 +306,6 @@ if (!infinite) { Time now = getProcessElapsedTime(); - if (now >= endTime) return 0; remaining = endTime - now; } } @@ -279,7 +343,7 @@ // compute_WaitForSingleObject_timeout(), // so that's 1 ms too little. Wait again then. if (!infinite && remaining < MSToTime(INFINITE)) - return 0; + return 0; // real complete or [we waited the full msecs] goto waitAgain; case WAIT_OBJECT_0: break; default: /* WAIT_FAILED */ maperrno(); return -1; @@ -346,6 +410,11 @@ // // PeekNamedPipe() does not block, so if it returns that // there is no new data, we have to sleep and try again. + + // Because PeekNamedPipe() doesn't block, we have to track + // manually whether we've called it one more time after `endTime` + // to fulfill Note [Guaranteed syscall time spent]. + bool endTimeReached = false; while (avail == 0) { BOOL success = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL ); if (success) { @@ -358,8 +427,9 @@ } else if (msecs == 0) { return 0; } else { + if (endTimeReached) return 0; // [we waited the full msecs] Time now = getProcessElapsedTime(); - if (now >= endTime) return 0; + if (now >= endTime) endTimeReached = true; Sleep(1); // 1 millisecond (smallest possible time on Windows) continue; } @@ -392,7 +462,7 @@ // compute_WaitForSingleObject_timeout(), // so that's 1 ms too little. Wait again then. if (!infinite && remaining < MSToTime(INFINITE)) - return 0; + return 0; // real complete or [we waited the full msecs] break; case WAIT_OBJECT_0: return 1; default: /* WAIT_FAILED */ maperrno(); return -1; @@ -401,7 +471,6 @@ // EINTR or a >(INFINITE - 1) timeout completed if (!infinite) { Time now = getProcessElapsedTime(); - if (now >= endTime) return 0; remaining = endTime - now; } } diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,47 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.12.0.0 *August 2018* + * Bundled with GHC 8.6.1 + * The STM invariant-checking mechanism (`always` and `alwaysSucceeds`), which + was deprecated in GHC 8.4, has been removed (as proposed in + ). + This is a bit earlier than proposed in the deprecation pragma included in + GHC 8.4, but due to community feedback we decided to move ahead with the + early removal. + + Existing users are encouraged to encapsulate their STM operations in safe + abstractions which can perform the invariant checking without help from the + runtime system. + + * Add a new module `GHC.ResponseFile` (previously defined in the `haddock` + package). (#13896) + + * Move the module `Data.Functor.Contravariant` from the + `contravariant` package to `base`. + + * `($!)` is now representation-polymorphic like `($)`. + + * Add `Applicative` (for `K1`), `Semigroup` and `Monoid` instances in + `GHC.Generics`. (#14849) + + * `asinh` for `Float` and `Double` is now numerically stable in the face of + non-small negative arguments and enormous arguments of either sign. (#14927) + + * `Numeric.showEFloat (Just 0)` and `Numeric.showGFloat (Just 0)` + now respect the user's requested precision. (#15115) + + * `Data.Monoid.Alt` now has `Foldable` and `Traversable` instances. (#15099) + + * `Data.Monoid.Ap` has been introduced + + * `Control.Exception.throw` is now levity polymorphic. (#15180) + + * `Data.Ord.Down` now has a number of new instances. These include: + `MonadFix`, `MonadZip`, `Data`, `Foldable`, `Traversable`, `Eq1`, `Ord1`, + `Read1`, `Show1`, `Generic`, `Generic1`. (#15098) + + ## 4.11.1.0 *April 2018* * Bundled with GHC 8.4.2 @@ -288,6 +329,9 @@ * New `Control.Exception.TypeError` datatype, which is thrown when an expression fails to typecheck when run using `-fdefer-type-errors` (#10284) + + * The `bitSize` method of `Data.Bits.Bits` now has a (partial!) + default implementation based on `bitSizeMaybe`. (#12970) ### New instances diff --git a/include/HsBase.h b/include/HsBase.h --- a/include/HsBase.h +++ b/include/HsBase.h @@ -24,6 +24,7 @@ #include "HsFFI.h" +#include #include #include #include @@ -152,7 +153,7 @@ #endif /* in inputReady.c */ -extern int fdReady(int fd, int write, int64_t msecs, int isSock); +extern int fdReady(int fd, bool write, int64_t msecs, bool isSock); /* ----------------------------------------------------------------------------- INLINE functions. @@ -288,7 +289,7 @@ return _chsize(fd,where); #else // ToDo: we should use _chsize_s() on Windows which allows a 64-bit -// offset, but it doesn't seem to be available from mingw at this time +// offset, but it doesn't seem to be available from mingw at this time // --SDM (01/2008) #error at least ftruncate or _chsize functions are required to build #endif @@ -519,13 +520,25 @@ extern void __hscore_set_saved_termios(int fd, void* ts); #if defined(_WIN32) +/* Defined in fs.c. */ +extern int __hs_swopen (const wchar_t* filename, int oflag, int shflag, + int pmode); + INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) { + int result = -1; if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND)) - return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); + result = __hs_swopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); // _O_NOINHERIT: see #2650 else - return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); + result = __hs_swopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); // _O_NOINHERIT: see #2650 + + /* This call is very important, otherwise the I/O system will not propagate + the correct error for why it failed. */ + if (result == -1) + maperrno (); + + return result; } #else INLINE int __hscore_open(char *file, int how, mode_t mode) { diff --git a/include/fs.h b/include/fs.h new file mode 100644 --- /dev/null +++ b/include/fs.h @@ -0,0 +1,36 @@ +/* ----------------------------------------------------------------------------- + * + * (c) Tamar Christina 2018 + * + * Windows I/O routines for file opening. + * + * NOTE: Only modify this file in utils/fs/ and rerun configure. Do not edit + * this file in any other directory as it will be overwritten. + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#include + +#if !defined(FS_NAMESPACE) +#define FS_NAMESPACE hs +#endif + +/* Play some dirty tricks to get CPP to expand correctly. */ +#define FS_FULL(ns, name) __##ns##_##name +#define prefix FS_NAMESPACE +#define FS_L(p, n) FS_FULL(p, n) +#define FS(name) FS_L(prefix, name) + +#if defined(_WIN32) +#include + +int FS(swopen) (const wchar_t* filename, int oflag, + int shflag, int pmode); +FILE *FS(fwopen) (const wchar_t* filename, const wchar_t* mode); +FILE *FS(fopen) (const char* filename, const char* mode); +#else + +FILE *FS(fopen) (const char* filename, const char* mode); +#endif