diff options
Diffstat (limited to 'libraries/base')
30 files changed, 264 insertions, 84 deletions
diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs index a2f342f83f..6770234926 100644 --- a/libraries/base/Control/Applicative.hs +++ b/libraries/base/Control/Applicative.hs @@ -96,7 +96,7 @@ instance Monad m => Functor (WrappedMonad m) where fmap f (WrapMonad v) = WrapMonad (liftM f v) instance Monad m => Applicative (WrappedMonad m) where - pure = WrapMonad . return + pure = WrapMonad . pure WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) instance MonadPlus m => Alternative (WrappedMonad m) where diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs index 9d09544eeb..1cc6062516 100644 --- a/libraries/base/Control/Arrow.hs +++ b/libraries/base/Control/Arrow.hs @@ -93,16 +93,14 @@ class Category a => Arrow a where -- | Send the first component of the input through the argument -- arrow, and copy the rest unchanged to the output. first :: a b c -> a (b,d) (c,d) + first = (*** id) -- | A mirror image of 'first'. -- -- The default definition may be overridden with a more efficient -- version if desired. second :: a b c -> a (d,b) (d,c) - second f = arr swap >>> first f >>> arr swap - where - swap :: (x,y) -> (y,x) - swap ~(x,y) = (y,x) + second = (id ***) -- | Split the input between the two argument arrows and combine -- their output. Note that this is in general not a functor. @@ -110,7 +108,8 @@ class Category a => Arrow a where -- The default definition may be overridden with a more efficient -- version if desired. (***) :: a b c -> a b' c' -> a (b,b') (c,c') - f *** g = first f >>> second g + f *** g = first f >>> arr swap >>> first g >>> arr swap + where swap ~(x,y) = (y,x) -- | Fanout: send the input to both argument arrows and combine -- their output. @@ -141,8 +140,6 @@ class Category a => Arrow a where instance Arrow (->) where arr f = f - first f = f *** id - second f = id *** f -- (f *** g) ~(x,y) = (f x, g y) -- sorry, although the above defn is fully H'98, nhc98 can't parse it. (***) f g ~(x,y) = (f x, g y) @@ -314,7 +311,6 @@ instance Arrow a => Applicative (ArrowMonad a) where ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id)) instance ArrowApply a => Monad (ArrowMonad a) where - return x = ArrowMonad (arr (\_ -> x)) ArrowMonad m >>= f = ArrowMonad $ m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index 35248bfba3..1786c3ded3 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -3,6 +3,7 @@ , MagicHash , UnboxedTuples , ScopedTypeVariables + , RankNTypes #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN @@ -73,6 +74,7 @@ module Control.Concurrent ( -- $boundthreads rtsSupportsBoundThreads, forkOS, + forkOSWithUnmask, isCurrentThreadBound, runInBoundThread, runInUnboundThread, @@ -180,7 +182,7 @@ attribute will block all other threads. -} --- | fork a thread and call the supplied function when the thread is about +-- | Fork a thread and call the supplied function when the thread is about -- to terminate, with an exception or a returned value. The function is -- called with asynchronous exceptions masked. -- @@ -316,6 +318,11 @@ forkOS action0 return tid | otherwise = failNonThreaded +-- | Like 'forkIOWithUnmask', but the child thread is a bound thread, +-- as with 'forkOS'. +forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkOSWithUnmask io = forkOS (io unsafeUnmask) + -- | Returns 'True' if the calling thread is /bound/, that is, if it is -- safe to use foreign libraries that rely on thread-local state from the -- calling thread. diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs index 55b28cfc9a..c99912e62d 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs @@ -71,13 +71,11 @@ instance Functor (ST s) where (f r,new_s) instance Applicative (ST s) where - pure = return + pure a = ST $ \ s -> (a,s) (<*>) = ap instance Monad (ST s) where - return a = ST $ \ s -> (a,s) - m >> k = m >>= \ _ -> k fail s = error s (ST m) >>= k diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 84b1c031b1..9134e13ba8 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -515,11 +515,7 @@ instance Bits Integer where complement = complementInteger shift x i@(I# i#) | i >= 0 = shiftLInteger x i# | otherwise = shiftRInteger x (negateInt# i#) - shiftL x (I# i#) = shiftLInteger x i# - shiftR x (I# i#) = shiftRInteger x i# - testBit x (I# i) = testBitInteger x i - zeroBits = 0 #if HAVE_INTEGER_GMP1 diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs index 09314f163e..31550d5ac7 100644 --- a/libraries/base/Data/Complex.hs +++ b/libraries/base/Data/Complex.hs @@ -213,5 +213,4 @@ instance Applicative Complex where f :+ g <*> a :+ b = f a :+ g b instance Monad Complex where - return a = a :+ a a :+ b >>= f = realPart (f a) :+ imagPart (f b) diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs index d727e5219d..50e95824c8 100644 --- a/libraries/base/Data/Either.hs +++ b/libraries/base/Data/Either.hs @@ -134,7 +134,6 @@ instance Applicative (Either e) where Right f <*> r = fmap f r instance Monad (Either e) where - return = Right Left l >>= _ = Left l Right r >>= k = k r diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs index 9f7ae24e66..46fb66650c 100644 --- a/libraries/base/Data/Functor/Identity.hs +++ b/libraries/base/Data/Functor/Identity.hs @@ -88,7 +88,6 @@ instance Applicative Identity where (<*>) = coerce instance Monad Identity where - return = Identity m >>= k = k (runIdentity m) instance MonadFix Identity where diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs index 6698a0ba58..d8bad07c7b 100644 --- a/libraries/base/Data/List/NonEmpty.hs +++ b/libraries/base/Data/List/NonEmpty.hs @@ -189,7 +189,6 @@ instance Applicative NonEmpty where (<*>) = ap instance Monad NonEmpty where - return a = a :| [] ~(a :| as) >>= f = b :| (bs ++ bs') where b :| bs = f a bs' = as >>= toList . f diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index c5a4d8bdf9..eff3836396 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -82,7 +82,6 @@ instance Applicative Dual where (<*>) = coerce instance Monad Dual where - return = Dual m >>= k = k (getDual m) -- | The monoid of endomorphisms under composition. @@ -126,7 +125,6 @@ instance Applicative Sum where (<*>) = coerce instance Monad Sum where - return = Sum m >>= k = k (getSum m) -- | Monoid under multiplication. @@ -146,7 +144,6 @@ instance Applicative Product where (<*>) = coerce instance Monad Product where - return = Product m >>= k = k (getProduct m) -- $MaybeExamples diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index a9146214c0..2dad8e4e78 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -90,8 +90,6 @@ instance Applicative Proxy where {-# INLINE (<*>) #-} instance Monad Proxy where - return _ = Proxy - {-# INLINE return #-} _ >>= _ = Proxy {-# INLINE (>>=) #-} diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index 661e513cba..f3f9f0b326 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -332,8 +332,7 @@ instance Applicative Min where Min f <*> Min x = Min (f x) instance Monad Min where - return = Min - _ >> a = a + (>>) = (*>) Min a >>= f = f a instance MonadFix Min where @@ -389,8 +388,7 @@ instance Applicative Max where Max f <*> Max x = Max (f x) instance Monad Max where - return = Max - _ >> a = a + (>>) = (*>) Max a >>= f = f a instance MonadFix Max where @@ -476,8 +474,7 @@ instance Applicative First where First f <*> First x = First (f x) instance Monad First where - return = First - _ >> a = a + (>>) = (*>) First a >>= f = f a instance MonadFix First where @@ -523,8 +520,7 @@ instance Applicative Last where Last f <*> Last x = Last (f x) instance Monad Last where - return = Last - _ >> a = a + (>>) = (*>) Last a >>= f = f a instance MonadFix Last where @@ -584,14 +580,13 @@ instance Applicative Option where pure a = Option (Just a) Option a <*> Option b = Option (a <*> b) -instance Monad Option where - return = pure + Option Nothing *> _ = Option Nothing + _ *> b = b +instance Monad Option where Option (Just a) >>= k = k a _ >>= _ = Option Nothing - - Option Nothing >> _ = Option Nothing - _ >> b = b + (>>) = (*>) instance Alternative Option where empty = Option Nothing diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs index 81e639cf37..9da76c6a34 100644 --- a/libraries/base/Data/Traversable.hs +++ b/libraries/base/Data/Traversable.hs @@ -196,9 +196,9 @@ instance Traversable Proxy where {-# INLINE traverse #-} sequenceA _ = pure Proxy {-# INLINE sequenceA #-} - mapM _ _ = return Proxy + mapM _ _ = pure Proxy {-# INLINE mapM #-} - sequence _ = return Proxy + sequence _ = pure Proxy {-# INLINE sequence #-} instance Traversable (Const m) where diff --git a/libraries/base/Data/Version.hs b/libraries/base/Data/Version.hs index aba8cf7f74..414b2aa859 100644 --- a/libraries/base/Data/Version.hs +++ b/libraries/base/Data/Version.hs @@ -36,7 +36,8 @@ module Data.Version ( makeVersion ) where -import Control.Monad ( Monad(..), liftM ) +import Data.Functor ( Functor(..) ) +import Control.Applicative ( Applicative(..) ) import Data.Bool ( (&&) ) import Data.Char ( isDigit, isAlphaNum ) import Data.Eq @@ -120,9 +121,9 @@ showVersion (Version branch tags) -- | A parser for versions in the format produced by 'showVersion'. -- parseVersion :: ReadP Version -parseVersion = do branch <- sepBy1 (liftM read (munch1 isDigit)) (char '.') - tags <- many (char '-' >> munch1 isAlphaNum) - return Version{versionBranch=branch, versionTags=tags} +parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.') + tags <- many (char '-' *> munch1 isAlphaNum) + pure Version{versionBranch=branch, versionTags=tags} -- | Construct tag-less 'Version' -- diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs index 26a19d8f71..653dcab055 100644 --- a/libraries/base/Debug/Trace.hs +++ b/libraries/base/Debug/Trace.hs @@ -150,8 +150,14 @@ traceShowId a = trace (show a) a {-| Like 'trace' but returning unit in an arbitrary 'Applicative' context. Allows -for convenient use in do-notation. Note that the application of 'trace' is not -an action in the 'Applicative' context, as 'traceIO' is in the 'IO' type. +for convenient use in do-notation. + +Note that the application of 'traceM' is not an action in the 'Applicative' +context, as 'traceIO' is in the 'IO' type. While the fresh bindings in the +following example will force the 'traceM' expressions to be reduced every time +the @do@-block is executed, @traceM "not crashed"@ would only be reduced once, +and the message would only be printed once. If your monad is in 'MonadIO', +@liftIO . traceIO@ may be a better option. > ... = do > x <- ... diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 9bd6124e6a..273950b1fb 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -309,7 +309,6 @@ instance Monoid a => Applicative ((,) a) where (u, f) <*> (v, x) = (u `mappend` v, f x) instance Monoid a => Monad ((,) a) where - return x = (mempty, x) (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) instance Monoid a => Monoid (IO a) where @@ -626,7 +625,6 @@ instance Applicative ((->) a) where (<*>) f g x = f x (g x) instance Monad ((->) r) where - return = const f >>= k = \ r -> k (f r) r instance Functor ((,) a) where @@ -652,7 +650,6 @@ instance Monad Maybe where (>>) = (*>) - return = Just fail _ = Nothing -- ----------------------------------------------------------------------------- @@ -735,8 +732,6 @@ instance Monad [] where xs >>= f = [y | x <- xs, y <- f x] {-# INLINE (>>) #-} (>>) = (*>) - {-# INLINE return #-} - return x = [x] {-# INLINE fail #-} fail _ = [] @@ -1063,18 +1058,19 @@ asTypeOf = const ---------------------------------------------- instance Functor IO where - fmap f x = x >>= (return . f) + fmap f x = x >>= (pure . f) instance Applicative IO where - pure = return - (<*>) = ap + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure = returnIO + m *> k = m >>= \ _ -> k + (<*>) = ap instance Monad IO where - {-# INLINE return #-} {-# INLINE (>>) #-} {-# INLINE (>>=) #-} - m >> k = m >>= \ _ -> k - return = returnIO + (>>) = (*>) (>>=) = bindIO fail s = failIO s diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index db6f841851..83934fe05a 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -626,19 +626,19 @@ unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) unSTM (STM a) = a instance Functor STM where - fmap f x = x >>= (return . f) + fmap f x = x >>= (pure . f) instance Applicative STM where - pure = return + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure x = returnSTM x (<*>) = ap + m *> k = thenSTM m k instance Monad STM where - {-# INLINE return #-} - {-# INLINE (>>) #-} {-# INLINE (>>=) #-} - m >> k = thenSTM m k - return x = returnSTM x m >>= k = bindSTM m k + (>>) = (*>) bindSTM :: STM a -> (a -> STM b) -> STM b bindSTM (STM m) k = STM ( \s -> diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index 8cdb10709d..6c40cba570 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -23,7 +23,8 @@ module GHC.Err( absentErr, error, undefined ) where import GHC.CString () -import GHC.Types +import GHC.Types (Char) +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 diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index 3fbae05c9a..02c6cfa54f 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -37,6 +37,7 @@ import Data.Typeable (Typeable, cast) -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show +import GHC.Stack.Types {- | The @SomeException@ type is the root of the exception type hierarchy. diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index 594f2665e8..f89fed1aa2 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -28,7 +28,8 @@ module GHC.Exception ( SomeException, errorCallException, errorCallWithCallStackException, divZeroException, overflowException, ratioZeroDenomException ) where -import GHC.Types( Char, CallStack ) +import GHC.Types ( Char ) +import GHC.Stack.Types ( CallStack ) data SomeException divZeroException, overflowException, ratioZeroDenomException :: SomeException diff --git a/libraries/base/GHC/GHCi.hs b/libraries/base/GHC/GHCi.hs index c11863520c..56874a5a12 100644 --- a/libraries/base/GHC/GHCi.hs +++ b/libraries/base/GHC/GHCi.hs @@ -38,11 +38,10 @@ instance Functor NoIO where fmap f (NoIO a) = NoIO (fmap f a) instance Applicative NoIO where - pure = return + pure a = NoIO (pure a) (<*>) = ap instance Monad NoIO where - return a = NoIO (return a) (>>=) k f = NoIO (noio k >>= noio . f) instance GHCiSandboxIO NoIO where diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index d98533b5b2..3e38930261 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -8,6 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -532,6 +533,65 @@ module GHC.Generics ( -- @ -- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } -- @ + +-- *** Representation of unlifted types +-- +-- | +-- +-- If one were to attempt to derive a Generic instance for a datatype with an +-- unlifted argument (for example, 'Int#'), one might expect the occurrence of +-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, +-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. +-- In fact, polymorphism over unlifted types is disallowed completely. +-- +-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' +-- instead. With this approach, however, the programmer has no way of knowing +-- whether the 'Int' is actually an 'Int#' in disguise. +-- +-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark +-- occurrences of common unlifted types: +-- +-- @ +-- data family URec a p +-- +-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } +-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } +-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } +-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } +-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } +-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } +-- @ +-- +-- Several type synonyms are provided for convenience: +-- +-- @ +-- type 'UAddr' = 'URec' ('Ptr' ()) +-- type 'UChar' = 'URec' 'Char' +-- type 'UDouble' = 'URec' 'Double' +-- type 'UFloat' = 'URec' 'Float' +-- type 'UInt' = 'URec' 'Int' +-- type 'UWord' = 'URec' 'Word' +-- @ +-- +-- The declaration +-- +-- @ +-- data IntHash = IntHash Int# +-- deriving 'Generic' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic' IntHash where +-- type 'Rep' IntHash = +-- 'D1' D1IntHash +-- ('C1' C1_0IntHash +-- ('S1' 'NoSelector' 'UInt')) +-- @ +-- +-- Currently, only the six unlifted types listed above are generated, but this +-- may be extended to encompass more unlifted types in the future. #if 0 -- *** Limitations -- @@ -548,6 +608,11 @@ module GHC.Generics ( V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..) + -- ** Unboxed representation types + , URec(..) + , type UAddr, type UChar, type UDouble + , type UFloat, type UInt, type UWord + -- ** Synonyms for convenience , Rec0, Par0, R, P , D1, C1, S1, D, C, S @@ -562,6 +627,8 @@ module GHC.Generics ( ) where -- We use some base types +import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) +import GHC.Ptr ( Ptr ) import GHC.Types import Data.Maybe ( Maybe(..) ) import Data.Either ( Either(..) ) @@ -614,6 +681,46 @@ infixr 7 :.: newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) } deriving (Eq, Ord, Read, Show, Generic) +-- | Constants of kind @#@ +data family URec (a :: *) (p :: *) + +-- | Used for marking occurrences of 'Addr#' +data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } + deriving (Eq, Ord, Generic) + +-- | Used for marking occurrences of 'Char#' +data instance URec Char p = UChar { uChar# :: Char# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Double#' +data instance URec Double p = UDouble { uDouble# :: Double# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Float#' +data instance URec Float p = UFloat { uFloat# :: Float# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Int#' +data instance URec Int p = UInt { uInt# :: Int# } + deriving (Eq, Ord, Show, Generic) + +-- | Used for marking occurrences of 'Word#' +data instance URec Word p = UWord { uWord# :: Word# } + deriving (Eq, Ord, Show, Generic) + +-- | Type synonym for 'URec': 'Addr#' +type UAddr = URec (Ptr ()) +-- | Type synonym for 'URec': 'Char#' +type UChar = URec Char +-- | Type synonym for 'URec': 'Double#' +type UDouble = URec Double +-- | Type synonym for 'URec': 'Float#' +type UFloat = URec Float +-- | Type synonym for 'URec': 'Int#' +type UInt = URec Int +-- | Type synonym for 'URec': 'Word#' +type UWord = URec Word + -- | Tag for K1: recursion (of kind *) data R -- | Tag for K1: parameters (other than the last) @@ -642,7 +749,6 @@ type C1 = M1 C -- | Type synonym for encoding meta-information for record selectors type S1 = M1 S - -- | Class for datatypes that represent datatypes class Datatype (d :: *) where -- | The name of the datatype (unqualified) diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs index d5320522a5..46c5196c9e 100644 --- a/libraries/base/GHC/ST.hs +++ b/libraries/base/GHC/ST.hs @@ -58,16 +58,15 @@ instance Functor (ST s) where (# new_s, f r #) } instance Applicative (ST s) where - pure = return + {-# INLINE pure #-} + {-# INLINE (*>) #-} + pure x = ST (\ s -> (# s, x #)) + m *> k = m >>= \ _ -> k (<*>) = ap instance Monad (ST s) where - {-# INLINE return #-} - {-# INLINE (>>) #-} {-# INLINE (>>=) #-} - return x = ST (\ s -> (# s, x #)) - m >> k = m >>= \ _ -> k - + (>>) = (*>) (ST m) >>= k = ST (\ s -> case (m s) of { (# new_s, r #) -> diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc index a2283ff656..6ef1fa5d25 100644 --- a/libraries/base/GHC/Stack.hsc +++ b/libraries/base/GHC/Stack.hsc @@ -22,6 +22,9 @@ module GHC.Stack ( whoCreated, errorWithStackTrace, + -- * Implicit parameter call stacks + SrcLoc(..), CallStack(..), + -- * Internals CostCentreStack, CostCentre, diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs new file mode 100644 index 0000000000..5c37f64713 --- /dev/null +++ b/libraries/base/GHC/Stack/Types.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Stack.Types +-- Copyright : (c) The University of Glasgow 2015 +-- License : see libraries/ghc-prim/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- type definitions for call-stacks via implicit parameters. +-- Use GHC.Exts from the base package instead of importing this +-- module directly. +-- +----------------------------------------------------------------------------- + +module GHC.Stack.Types ( + -- * Implicit parameter call stacks + SrcLoc(..), CallStack(..), + ) where + +import GHC.Types + +-- Make implicit dependency known to build system +import GHC.Tuple () +import GHC.Integer () + +---------------------------------------------------------------------- +-- Explicit call-stacks built via ImplicitParams +---------------------------------------------------------------------- + +-- | @CallStack@s are an alternate method of obtaining the call stack at a given +-- point in the program. +-- +-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will +-- solve it with the current location. If another @CallStack@ implicit-parameter +-- is in-scope (e.g. as a function argument), the new location will be appended +-- to the one in-scope, creating an explicit call-stack. For example, +-- +-- @ +-- myerror :: (?loc :: CallStack) => String -> a +-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) +-- @ +-- ghci> myerror "die" +-- *** Exception: die +-- CallStack: +-- ?loc, called at MyError.hs:7:51 in main:MyError +-- myerror, called at <interactive>:2:1 in interactive:Ghci1 +-- +-- @CallStack@s do not interact with the RTS and do not require compilation with +-- @-prof@. On the other hand, as they are built up explicitly using +-- implicit-parameters, they will generally not contain as much information as +-- the simulated call-stacks maintained by the RTS. +-- +-- A @CallStack@ is a @[(String, SrcLoc)]@. The @String@ is the name of +-- function that was called, the 'SrcLoc' is the call-site. The list is +-- ordered with the most recently called function at the head. +-- +-- @since 4.8.2.0 +data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] } + -- See Note [Overview of implicit CallStacks] + +-- | A single location in the source code. +-- +-- @since 4.8.2.0 +data SrcLoc = SrcLoc + { srcLocPackage :: [Char] + , srcLocModule :: [Char] + , srcLocFile :: [Char] + , srcLocStartLine :: Int + , srcLocStartCol :: Int + , srcLocEndLine :: Int + , srcLocEndCol :: Int + } diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs index 302d027c0a..117d70525a 100644 --- a/libraries/base/GHC/StaticPtr.hs +++ b/libraries/base/GHC/StaticPtr.hs @@ -83,7 +83,7 @@ foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a) -- | Miscelaneous information available for debugging purposes. data StaticPtrInfo = StaticPtrInfo { -- | Package key of the package where the static pointer is defined - spInfoPackageKey :: String + spInfoUnitId :: String -- | Name of the module where the static pointer is defined , spInfoModuleName :: String -- | An internal name that is distinct for every static pointer defined in diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs index 034411d6bf..bae2abc90e 100644 --- a/libraries/base/Text/ParserCombinators/ReadP.hs +++ b/libraries/base/Text/ParserCombinators/ReadP.hs @@ -103,7 +103,7 @@ data P a -- Monad, MonadPlus instance Applicative P where - pure = return + pure x = Result x Fail (<*>) = ap instance MonadPlus P where @@ -111,8 +111,6 @@ instance MonadPlus P where mplus = (<|>) instance Monad P where - return x = Result x Fail - (Get f) >>= k = Get (\c -> f c >>= k) (Look f) >>= k = Look (\s -> f s >>= k) Fail >>= _ = Fail @@ -161,11 +159,10 @@ instance Functor ReadP where fmap h (R f) = R (\k -> f (k . h)) instance Applicative ReadP where - pure = return + pure x = R (\k -> k x) (<*>) = ap instance Monad ReadP where - return x = R (\k -> k x) fail _ = R (\_ -> Fail) R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs index 027648d9e8..02268364ca 100644 --- a/libraries/base/Text/ParserCombinators/ReadPrec.hs +++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs @@ -75,11 +75,10 @@ instance Functor ReadPrec where fmap h (P f) = P (\n -> fmap h (f n)) instance Applicative ReadPrec where - pure = return + pure x = P (\_ -> pure x) (<*>) = ap instance Monad ReadPrec where - return x = P (\_ -> return x) fail s = P (\_ -> fail s) P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 662f2747d7..326f4579fd 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -252,6 +252,7 @@ Library GHC.Show GHC.Stable GHC.Stack + GHC.Stack.Types GHC.Stats GHC.Storable GHC.TopHandler @@ -341,6 +342,6 @@ Library GHC.Event.TimerManager GHC.Event.Unique - -- We need to set the package key to base (without a version number) + -- We need to set the unit id to base (without a version number) -- as it's magic. ghc-options: -this-package-key base diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index b40bfefe91..24a6e7fd5c 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -62,6 +62,17 @@ super-class of `Monoid` in the future). These modules were provided by the `semigroups` package previously. (#10365) + * Add `URec`, `UAddr`, `UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord` to + `GHC.Generics` as part of making GHC generics capable of handling + unlifted types (#10868) + + * Keep `shift{L,R}` on `Integer` with negative shift-arguments from + segfaulting (#10571) + + * Add `forkOSWithUnmask` to `Control.Concurrent`, which is like + `forkIOWithUnmask`, but the child is run in a bound thread. + + ## 4.8.1.0 *Jul 2015* * Bundled with GHC 7.10.2 |