diff --git a/Control/Applicative.hs b/Control/Applicative.hs --- a/Control/Applicative.hs +++ b/Control/Applicative.hs @@ -1,9 +1,7 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | @@ -57,38 +55,13 @@ import Data.Ord import Data.Foldable (Foldable(..)) import Data.Functor ((<$>)) +import Data.Functor.Const (Const(..)) import GHC.Base import GHC.Generics import GHC.List (repeat, zipWith) -import GHC.Read (Read(readsPrec), readParen, lex) -import GHC.Show (Show(showsPrec), showParen, showString) - -newtype Const a b = Const { getConst :: a } - deriving (Generic, Generic1, Monoid, Eq, Ord) - -instance Read a => Read (Const a b) where - readsPrec d = readParen (d > 10) - $ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s] - -instance Show a => Show (Const a b) where - showsPrec d (Const x) = showParen (d > 10) $ - showString "Const " . showsPrec 11 x - -instance Foldable (Const m) where - foldMap _ _ = mempty - -instance Functor (Const m) where - fmap _ (Const v) = Const v - -instance Monoid m => Applicative (Const m) where - pure _ = Const mempty - (<*>) = coerce (mappend :: m -> m -> m) --- This is pretty much the same as --- Const f <*> Const v = Const (f `mappend` v) --- but guarantees that mappend for Const a b will have the same arity --- as the one for a; it won't create a closure to raise the arity --- to 2. +import GHC.Read (Read) +import GHC.Show (Show) newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } deriving (Generic, Generic1, Monad) @@ -97,7 +70,7 @@ 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 @@ -123,7 +96,9 @@ -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ -- newtype ZipList a = ZipList { getZipList :: [a] } - deriving (Show, Eq, Ord, Read, Functor, Generic, Generic1) + deriving ( Show, Eq, Ord, Read, Functor + , Foldable, Generic, Generic1) +-- See Data.Traversable for Traversabel instance due to import loops instance Applicative ZipList where pure x = ZipList (repeat x) diff --git a/Control/Arrow.hs b/Control/Arrow.hs --- a/Control/Arrow.hs +++ b/Control/Arrow.hs @@ -1,5 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} + -- The RULES for the methods of class Arrow may never fire + -- e.g. compose/arr; see Trac #10528 ----------------------------------------------------------------------------- -- | @@ -83,6 +86,7 @@ -- which may be overridden for efficiency. class Category a => Arrow a where + {-# MINIMAL arr, (first | (***)) #-} -- | Lift a function to an arrow. arr :: (b -> c) -> a b c @@ -90,16 +94,14 @@ -- | 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. @@ -107,7 +109,8 @@ -- 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. @@ -138,8 +141,6 @@ 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) @@ -215,21 +216,19 @@ -- be overridden for efficiency. class Arrow a => ArrowChoice a where + {-# MINIMAL (left | (+++)) #-} -- | Feed marked inputs through the argument arrow, passing the -- rest through unchanged to the output. left :: a b c -> a (Either b d) (Either c d) + left = (+++ id) -- | A mirror image of 'left'. -- -- The default definition may be overridden with a more efficient -- version if desired. right :: a b c -> a (Either d b) (Either d c) - right f = arr mirror >>> left f >>> arr mirror - where - mirror :: Either x y -> Either y x - mirror (Left x) = Right x - mirror (Right y) = Left y + right = (id +++) -- | Split the input between the two argument arrows, retagging -- and merging their outputs. @@ -238,7 +237,11 @@ -- The default definition may be overridden with a more efficient -- version if desired. (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c') - f +++ g = left f >>> right g + f +++ g = left f >>> arr mirror >>> left g >>> arr mirror + where + mirror :: Either x y -> Either y x + mirror (Left x) = Right x + mirror (Right y) = Left y -- | Fanin: Split the input between the two argument arrows and -- merge their outputs. @@ -311,7 +314,6 @@ 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/Control/Category.hs b/Control/Category.hs --- a/Control/Category.hs +++ b/Control/Category.hs @@ -2,6 +2,9 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} + -- The RULES for the methods of class Category may never fire + -- e.g. identity/left, identity/right, association; see Trac #10528 ----------------------------------------------------------------------------- -- | diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -3,8 +3,9 @@ , MagicHash , UnboxedTuples , ScopedTypeVariables + , RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN -- and Control.Concurrent.SampleVar imports. @@ -73,6 +74,7 @@ -- $boundthreads rtsSupportsBoundThreads, forkOS, + forkOSWithUnmask, isCurrentThreadBound, runInBoundThread, runInUnboundThread, @@ -107,7 +109,7 @@ import GHC.Conc hiding (threadWaitRead, threadWaitWrite, threadWaitReadSTM, threadWaitWriteSTM) -import GHC.IO ( unsafeUnmask ) +import GHC.IO ( unsafeUnmask, catchException ) import GHC.IORef ( newIORef, readIORef, writeIORef ) import GHC.Base @@ -180,7 +182,7 @@ -} --- | 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. -- @@ -306,7 +308,7 @@ MaskedInterruptible -> action0 MaskedUninterruptible -> uninterruptibleMask_ action0 - action_plus = Exception.catch action1 childHandler + action_plus = catchException action1 childHandler entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus) err <- forkOS_createThread entry @@ -316,6 +318,11 @@ 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. @@ -374,7 +381,7 @@ mv <- newEmptyMVar mask $ \restore -> do tid <- forkIO $ Exception.try (restore action) >>= putMVar mv - let wait = takeMVar mv `Exception.catch` \(e :: SomeException) -> + let wait = takeMVar mv `catchException` \(e :: SomeException) -> Exception.throwTo tid e >> wait wait >>= unsafeResult else action @@ -405,7 +412,7 @@ return () -- hWaitForInput does work properly, but we can only -- do this for stdin since we know its FD. - _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" + _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" #else = GHC.Conc.threadWaitRead fd #endif @@ -421,7 +428,7 @@ threadWaitWrite fd #ifdef mingw32_HOST_OS | threaded = withThread (waitFd fd 1) - | otherwise = error "threadWaitWrite requires -threaded on Windows" + | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else = GHC.Conc.threadWaitWrite fd #endif @@ -445,7 +452,7 @@ Just (Left e) -> throwSTM (e :: IOException) let killAction = return () return (waitAction, killAction) - | otherwise = error "threadWaitReadSTM requires -threaded on Windows" + | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows" #else = GHC.Conc.threadWaitReadSTM fd #endif @@ -469,7 +476,7 @@ Just (Left e) -> throwSTM (e :: IOException) let killAction = return () return (waitAction, killAction) - | otherwise = error "threadWaitWriteSTM requires -threaded on Windows" + | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows" #else = GHC.Conc.threadWaitWriteSTM fd #endif diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs --- a/Control/Concurrent/Chan.hs +++ b/Control/Concurrent/Chan.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -14,6 +14,11 @@ -- -- Unbounded channels. -- +-- The channels are implemented with @MVar@s and therefore inherit all the +-- caveats that apply to @MVar@s (possibility of races, deadlocks etc). The +-- stm (software transactional memory) library has a more robust implementation +-- of channels called @TChan@s. +-- ----------------------------------------------------------------------------- module Control.Concurrent.Chan @@ -37,7 +42,6 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import Control.Concurrent.MVar import Control.Exception (mask_) -import Data.Typeable #define _UPK_(x) {-# UNPACK #-} !(x) @@ -49,7 +53,7 @@ data Chan a = Chan _UPK_(MVar (Stream a)) _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar - deriving (Eq,Typeable) + deriving (Eq) type Stream a = MVar (ChItem a) diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs --- a/Control/Concurrent/MVar.hs +++ b/Control/Concurrent/MVar.hs @@ -270,5 +270,5 @@ -- -- @since 4.6.0.0 mkWeakMVar :: MVar a -> IO () -> IO (Weak (MVar a)) -mkWeakMVar m@(MVar m#) f = IO $ \s -> - case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #) +mkWeakMVar m@(MVar m#) (IO f) = IO $ \s -> + case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #) diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs --- a/Control/Concurrent/QSem.hs +++ b/Control/Concurrent/QSem.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-} -{-# LANGUAGE AutoDeriveTypeable, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs --- a/Control/Concurrent/QSemN.hs +++ b/Control/Concurrent/QSemN.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-} -{-# LANGUAGE AutoDeriveTypeable, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- @@ -28,7 +28,6 @@ import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar , putMVar, newMVar , tryPutMVar, isEmptyMVar) -import Data.Typeable import Control.Exception import Data.Maybe @@ -43,7 +42,6 @@ -- is safe; it never loses any of the resource. -- data QSemN = QSemN !(MVar (Int, [(Int, MVar ())], [(Int, MVar ())])) - deriving Typeable -- The semaphore state (i, xs, ys): -- diff --git a/Control/Exception.hs b/Control/Exception.hs --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -56,6 +56,7 @@ RecSelError(..), RecUpdError(..), ErrorCall(..), + TypeError(..), -- * Throwing exceptions throw, @@ -105,6 +106,7 @@ uninterruptibleMask_, MaskingState(..), getMaskingState, + interruptible, allowInterrupt, -- *** Applying @mask@ to an exception handler @@ -133,7 +135,7 @@ import Control.Exception.Base import GHC.Base -import GHC.IO (unsafeUnmask) +import GHC.IO (interruptible) -- | You need this when using 'catches'. data Handler a = forall e . Exception e => Handler (e -> IO a) @@ -214,14 +216,14 @@ -- | When invoked inside 'mask', this function allows a masked -- asynchronous exception to be raised, if one exists. It is -- equivalent to performing an interruptible operation (see --- #interruptible#), but does not involve any actual blocking. +-- #interruptible), but does not involve any actual blocking. -- -- When called outside 'mask', or inside 'uninterruptibleMask', this -- function has no effect. -- -- @since 4.4.0.0 allowInterrupt :: IO () -allowInterrupt = unsafeUnmask $ return () +allowInterrupt = interruptible $ return () {- $async diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -39,6 +39,7 @@ RecSelError(..), RecUpdError(..), ErrorCall(..), + TypeError(..), -- #10284, custom error type for deferred type errors -- * Throwing exceptions throwIO, @@ -92,7 +93,7 @@ -- * Calls for GHC runtime recSelError, recConError, irrefutPatError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, - absentError, + absentError, typeError, nonTermination, nestedAtomically, ) where @@ -104,7 +105,6 @@ -- import GHC.Exception hiding ( Exception ) import GHC.Conc.Sync -import Data.Dynamic import Data.Either ----------------------------------------------------------------------------- @@ -147,7 +147,7 @@ => IO a -- ^ The computation to run -> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a -catch = catchException +catch act = catchException (lazy act) -- | The function 'catchJust' is like 'catch', but it takes an extra -- argument which is an /exception predicate/, a function which @@ -297,7 +297,7 @@ -- |A pattern match failed. The @String@ gives information about the -- source location of the pattern. -data PatternMatchFail = PatternMatchFail String deriving Typeable +newtype PatternMatchFail = PatternMatchFail String instance Show PatternMatchFail where showsPrec _ (PatternMatchFail err) = showString err @@ -311,7 +311,7 @@ -- multiple constructors, where some fields are in one constructor -- but not another. The @String@ gives information about the source -- location of the record selector. -data RecSelError = RecSelError String deriving Typeable +newtype RecSelError = RecSelError String instance Show RecSelError where showsPrec _ (RecSelError err) = showString err @@ -323,7 +323,7 @@ -- |An uninitialised record field was used. The @String@ gives -- information about the source location where the record was -- constructed. -data RecConError = RecConError String deriving Typeable +newtype RecConError = RecConError String instance Show RecConError where showsPrec _ (RecConError err) = showString err @@ -337,7 +337,7 @@ -- multiple constructors, where some fields are in one constructor -- but not another. The @String@ gives information about the source -- location of the record update. -data RecUpdError = RecUpdError String deriving Typeable +newtype RecUpdError = RecUpdError String instance Show RecUpdError where showsPrec _ (RecUpdError err) = showString err @@ -349,7 +349,7 @@ -- |A class method without a definition (neither a default definition, -- nor a definition in the appropriate instance) was called. The -- @String@ gives information about which method it was. -data NoMethodError = NoMethodError String deriving Typeable +newtype NoMethodError = NoMethodError String instance Show NoMethodError where showsPrec _ (NoMethodError err) = showString err @@ -358,11 +358,25 @@ ----- +-- |An expression that didn't typecheck during compile time was called. +-- This is only possible with -fdefer-type-errors. The @String@ gives +-- details about the failed type check. +-- +-- @since 4.9.0.0 +newtype TypeError = TypeError String + +instance Show TypeError where + showsPrec _ (TypeError err) = showString err + +instance Exception TypeError + +----- + -- |Thrown when the runtime system detects that the computation is -- guaranteed not to terminate. Note that there is no guarantee that -- the runtime system will notice whether any given computation is -- guaranteed to terminate or not. -data NonTermination = NonTermination deriving Typeable +data NonTermination = NonTermination instance Show NonTermination where showsPrec _ NonTermination = showString "<>" @@ -373,7 +387,7 @@ -- |Thrown when the program attempts to call @atomically@, from the @stm@ -- package, inside another call to @atomically@. -data NestedAtomically = NestedAtomically deriving Typeable +data NestedAtomically = NestedAtomically instance Show NestedAtomically where showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested" @@ -384,19 +398,20 @@ recSelError, recConError, irrefutPatError, runtimeError, nonExhaustiveGuardsError, patError, noMethodBindingError, - absentError + absentError, typeError :: Addr# -> a -- All take a UTF8-encoded C string recSelError s = throw (RecSelError ("No match in record selector " ++ unpackCStringUtf8# s)) -- No location info unfortunately -runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately -absentError s = error ("Oops! Entered absent arg " ++ unpackCStringUtf8# s) +runtimeError s = errorWithoutStackTrace (unpackCStringUtf8# s) -- No location info unfortunately +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")) +typeError s = throw (TypeError (unpackCStringUtf8# s)) -- GHC's RTS calls this nonTermination :: SomeException diff --git a/Control/Monad.hs b/Control/Monad.hs --- a/Control/Monad.hs +++ b/Control/Monad.hs @@ -75,12 +75,13 @@ , (<$!>) ) where -import Data.Foldable ( Foldable, sequence_, msum, mapM_, foldlM, forM_ ) -import Data.Functor ( void ) -import Data.Traversable ( forM, mapM, sequence ) +import Data.Foldable ( Foldable, sequence_, sequenceA_, msum, mapM_, foldlM, forM_ ) +import Data.Functor ( void, (<$>) ) +import Data.Traversable ( forM, mapM, traverse, sequence, sequenceA ) import GHC.Base hiding ( mapM, sequence ) -import GHC.List ( zipWith, unzip, replicate ) +import GHC.List ( zipWith, unzip ) +import GHC.Num ( (-) ) -- ----------------------------------------------------------------------------- -- Functions mandated by the Prelude @@ -94,13 +95,8 @@ -- | This generalizes the list-based 'filter' function. {-# INLINE filterM #-} -filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] -filterM p = foldr go (return []) - where - go x r = do - flg <- p x - ys <- r - return (if flg then x:ys else ys) +filterM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterM p = foldr (\ x -> liftA2 (\ flg -> if flg then (x:) else id) (p x)) (pure []) infixr 1 <=<, >=> @@ -108,14 +104,19 @@ (>=>) :: 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 Kleisli composition of monads. @('>=>')@, with the arguments flipped. +-- +-- Note how this operator resembles function composition @('.')@: +-- +-- > (.) :: (b -> c) -> (a -> b) -> a -> c +-- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) (<=<) = flip (>=>) -- | @'forever' act@ repeats the action infinitely. -forever :: (Monad m) => m a -> m b +forever :: (Applicative f) => f a -> f b {-# INLINE forever #-} -forever a = let a' = a >> a' in a' +forever a = let a' = a *> a' in a' -- Use explicit sharing here, as it is prevents a space leak regardless of -- optimizations. @@ -125,19 +126,19 @@ -- | The 'mapAndUnzipM' function maps its first argument over a list, returning -- the result as a pair of lists. This function is mainly used with complicated -- data structures or a state-transforming monad. -mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +mapAndUnzipM :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) {-# INLINE mapAndUnzipM #-} -mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip +mapAndUnzipM f xs = unzip <$> traverse f xs --- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads. -zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary applicative functors. +zipWithM :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c] {-# INLINE zipWithM #-} -zipWithM f xs ys = sequence (zipWith f xs ys) +zipWithM f xs ys = sequenceA (zipWith f xs ys) -- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. -zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m () {-# INLINE zipWithM_ #-} -zipWithM_ f xs ys = sequence_ (zipWith f xs ys) +zipWithM_ f xs ys = sequenceA_ (zipWith f xs ys) {- | The 'foldM' function is analogous to 'foldl', except that its result is encapsulated in a monad. Note that 'foldM' works from left-to-right over @@ -173,20 +174,55 @@ {-# SPECIALISE foldM_ :: (a -> b -> Maybe a) -> a -> [b] -> Maybe () #-} foldM_ f a xs = foldlM f a xs >> return () +{- +Note [Worker/wrapper transform on replicateM/replicateM_ +-------------------------------------------------------- + +The implementations of replicateM and replicateM_ both leverage the +worker/wrapper transform. The simpler implementation of replicateM_, as an +example, would be: + + replicateM_ 0 _ = pure () + replicateM_ n f = f *> replicateM_ (n - 1) f + +However, the self-recrusive nature of this implementation inhibits inlining, +which means we never get to specialise to the action (`f` in the code above). +By contrast, the implementation below with a local loop makes it possible to +inline the entire definition (as hapens for foldr, for example) thereby +specialising for the particular action. + +For further information, see this Trac comment, which includes side-by-side +Core. + +https://ghc.haskell.org/trac/ghc/ticket/11795#comment:6 + +-} + -- | @'replicateM' n act@ performs the action @n@ times, -- gathering the results. -replicateM :: (Monad m) => Int -> m a -> m [a] +replicateM :: (Applicative m) => Int -> m a -> m [a] {-# INLINEABLE replicateM #-} {-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-} {-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-} -replicateM n x = sequence (replicate n x) +replicateM cnt0 f = + loop cnt0 + where + loop cnt + | cnt <= 0 = pure [] + | otherwise = liftA2 (:) f (loop (cnt - 1)) -- | Like 'replicateM', but discards the result. -replicateM_ :: (Monad m) => Int -> m a -> m () +replicateM_ :: (Applicative m) => Int -> m a -> m () {-# INLINEABLE replicateM_ #-} {-# SPECIALISE replicateM_ :: Int -> IO a -> IO () #-} {-# SPECIALISE replicateM_ :: Int -> Maybe a -> Maybe () #-} -replicateM_ n x = sequence_ (replicate n x) +replicateM_ cnt0 f = + loop cnt0 + where + loop cnt + | cnt <= 0 = pure () + | otherwise = f *> loop (cnt - 1) + -- | The reverse of 'when'. unless :: (Applicative f) => Bool -> f () -> f () diff --git a/Control/Monad/Fail.hs b/Control/Monad/Fail.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Fail.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : Control.Monad.Fail +-- Copyright : (C) 2015 David Luposchainsky, +-- (C) 2015 Herbert Valerio Riedel +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Transitional module providing the 'MonadFail' class and primitive +-- instances. +-- +-- This module can be imported for defining forward compatible +-- 'MonadFail' instances: +-- +-- @ +-- import qualified Control.Monad.Fail as Fail +-- +-- instance Monad Foo where +-- (>>=) = {- ...bind impl... -} +-- +-- -- Provide legacy 'fail' implementation for when +-- -- new-style MonadFail desugaring is not enabled. +-- fail = Fail.fail +-- +-- instance Fail.MonadFail Foo where +-- fail = {- ...fail implementation... -} +-- @ +-- +-- See +-- for more details. +-- +-- @since 4.9.0.0 +-- +module Control.Monad.Fail ( MonadFail(fail) ) where + +import GHC.Base (String, Monad(), Maybe(Nothing), IO()) +import {-# SOURCE #-} GHC.IO (failIO) + +-- | When a value is bound in @do@-notation, the pattern on the left +-- hand side of @<-@ might not match. In this case, this class +-- provides a function to recover. +-- +-- A 'Monad' without a 'MonadFail' instance may only be used in conjunction +-- with pattern that always match, such as newtypes, tuples, data types with +-- only a single data constructor, and irrefutable patterns (@~pat@). +-- +-- Instances of 'MonadFail' should satisfy the following law: @fail s@ should +-- be a left zero for '>>=', +-- +-- @ +-- fail s >>= f = fail s +-- @ +-- +-- If your 'Monad' is also 'MonadPlus', a popular definition is +-- +-- @ +-- fail _ = mzero +-- @ +-- +-- @since 4.9.0.0 +class Monad m => MonadFail m where + fail :: String -> m a + + +instance MonadFail Maybe where + fail _ = Nothing + +instance MonadFail [] where + {-# INLINE fail #-} + fail _ = [] + +instance MonadFail IO where + fail = failIO diff --git a/Control/Monad/Fix.hs b/Control/Monad/Fix.hs --- a/Control/Monad/Fix.hs +++ b/Control/Monad/Fix.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -26,7 +27,10 @@ import Data.Either import Data.Function ( fix ) import Data.Maybe -import GHC.Base ( Monad, error, (.) ) +import Data.Monoid ( Dual(..), Sum(..), Product(..) + , First(..), Last(..), Alt(..) ) +import GHC.Base ( Monad, errorWithoutStackTrace, (.) ) +import GHC.Generics import GHC.List ( head, tail ) import GHC.ST import System.IO @@ -61,7 +65,7 @@ instance MonadFix Maybe where mfix f = let a = f (unJust a) in a where unJust (Just x) = x - unJust Nothing = error "mfix Maybe: Nothing" + unJust Nothing = errorWithoutStackTrace "mfix Maybe: Nothing" instance MonadFix [] where mfix f = case fix (f . head) of @@ -77,7 +81,43 @@ instance MonadFix (Either e) where mfix f = let a = f (unRight a) in a where unRight (Right x) = x - unRight (Left _) = error "mfix Either: Left" + unRight (Left _) = errorWithoutStackTrace "mfix Either: Left" instance MonadFix (ST s) where mfix = fixST + +-- Instances of Data.Monoid wrappers + +instance MonadFix Dual where + mfix f = Dual (fix (getDual . f)) + +instance MonadFix Sum where + mfix f = Sum (fix (getSum . f)) + +instance MonadFix Product where + mfix f = Product (fix (getProduct . f)) + +instance MonadFix First where + mfix f = First (mfix (getFirst . f)) + +instance MonadFix Last where + mfix f = Last (mfix (getLast . f)) + +instance MonadFix f => MonadFix (Alt f) where + mfix f = Alt (mfix (getAlt . f)) + +-- Instances for GHC.Generics +instance MonadFix Par1 where + mfix f = Par1 (fix (unPar1 . f)) + +instance MonadFix f => MonadFix (Rec1 f) where + mfix f = Rec1 (mfix (unRec1 . f)) + +instance MonadFix f => MonadFix (M1 i c f) where + mfix f = M1 (mfix (unM1. f)) + +instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where + mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f)) + where + fstP (a :*: _) = a + sndP (_ :*: b) = b diff --git a/Control/Monad/IO/Class.hs b/Control/Monad/IO/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/IO/Class.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.IO.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Class of monads based on @IO@. +----------------------------------------------------------------------------- + +module Control.Monad.IO.Class ( + MonadIO(..) + ) where + +-- | Monads in which 'IO' computations may be embedded. +-- Any monad built by applying a sequence of monad transformers to the +-- 'IO' monad will be an instance of this class. +-- +-- Instances should satisfy the following laws, which state that 'liftIO' +-- is a transformer of monads: +-- +-- * @'liftIO' . 'return' = 'return'@ +-- +-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ + +class (Monad m) => MonadIO m where + -- | Lift a computation from the 'IO' monad. + liftIO :: IO a -> m a + +instance MonadIO IO where + liftIO = id diff --git a/Control/Monad/ST/Lazy/Imp.hs b/Control/Monad/ST/Lazy/Imp.hs --- a/Control/Monad/ST/Lazy/Imp.hs +++ b/Control/Monad/ST/Lazy/Imp.hs @@ -71,14 +71,12 @@ (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 + fail s = errorWithoutStackTrace s (ST m) >>= k = ST $ \ s -> diff --git a/Control/Monad/Zip.hs b/Control/Monad/Zip.hs --- a/Control/Monad/Zip.hs +++ b/Control/Monad/Zip.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -17,7 +18,10 @@ module Control.Monad.Zip where -import Control.Monad (liftM) +import Control.Monad (liftM, liftM2) +import Data.Monoid +import Data.Proxy +import GHC.Generics -- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` -- @@ -53,3 +57,43 @@ mzipWith = zipWith munzip = unzip +instance MonadZip Dual where + -- Cannot use coerce, it's unsafe + mzipWith = liftM2 + +instance MonadZip Sum where + mzipWith = liftM2 + +instance MonadZip Product where + mzipWith = liftM2 + +instance MonadZip Maybe where + mzipWith = liftM2 + +instance MonadZip First where + mzipWith = liftM2 + +instance MonadZip Last where + mzipWith = liftM2 + +instance MonadZip f => MonadZip (Alt f) where + mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb) + +instance MonadZip Proxy where + mzipWith _ _ _ = Proxy + +-- Instances for GHC.Generics +instance MonadZip U1 where + mzipWith _ _ _ = U1 + +instance MonadZip Par1 where + mzipWith = liftM2 + +instance MonadZip f => MonadZip (Rec1 f) where + mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb) + +instance MonadZip f => MonadZip (M1 i c f) where + mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb) + +instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where + mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2 diff --git a/Data/Bifunctor.hs b/Data/Bifunctor.hs --- a/Data/Bifunctor.hs +++ b/Data/Bifunctor.hs @@ -18,6 +18,7 @@ ) where import Control.Applicative ( Const(..) ) +import GHC.Generics ( K1(..) ) -- | Formally, the class 'Bifunctor' represents a bifunctor -- from @Hask@ -> @Hask@. @@ -99,3 +100,6 @@ instance Bifunctor Const where bimap f _ (Const a) = Const (f a) + +instance Bifunctor (K1 i) where + bimap f _ (K1 c) = K1 (f c) diff --git a/Data/Bits.hs b/Data/Bits.hs --- a/Data/Bits.hs +++ b/Data/Bits.hs @@ -515,15 +515,7 @@ complement = complementInteger shift x i@(I# i#) | i >= 0 = shiftLInteger x i# | otherwise = shiftRInteger x (negateInt# i#) - shiftL x i@(I# i#) - | i < 0 = error "Bits.shiftL(Integer): negative shift" - | otherwise = shiftLInteger x i# - shiftR x i@(I# i#) - | i < 0 = error "Bits.shiftR(Integer): negative shift" - | otherwise = shiftRInteger x i# - testBit x (I# i) = testBitInteger x i - zeroBits = 0 #if HAVE_INTEGER_GMP1 @@ -537,7 +529,7 @@ rotate x i = shift x i -- since an Integer never wraps around bitSizeMaybe _ = Nothing - bitSize _ = error "Data.Bits.bitSize(Integer)" + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True ----------------------------------------------------------------------------- diff --git a/Data/Char.hs b/Data/Char.hs --- a/Data/Char.hs +++ b/Data/Char.hs @@ -53,14 +53,12 @@ ) where import GHC.Base -import GHC.Arr (Ix) import GHC.Char import GHC.Real (fromIntegral) import GHC.Show -import GHC.Read (Read, readLitChar, lexLitChar) +import GHC.Read (readLitChar, lexLitChar) import GHC.Unicode import GHC.Num -import GHC.Enum -- $setup -- Allow the use of Prelude in doctests. @@ -99,127 +97,12 @@ | (fromIntegral dec::Word) <= 9 = dec | (fromIntegral hexl::Word) <= 5 = hexl + 10 | (fromIntegral hexu::Word) <= 5 = hexu + 10 - | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh + | otherwise = errorWithoutStackTrace ("Char.digitToInt: not a digit " ++ show c) -- sigh where dec = ord c - ord '0' hexl = ord c - ord 'a' hexu = ord c - ord 'A' --- | Unicode General Categories (column 2 of the UnicodeData table) in --- the order they are listed in the Unicode standard (the Unicode --- Character Database, in particular). --- --- ==== __Examples__ --- --- Basic usage: --- --- >>> :t OtherLetter --- OtherLetter :: GeneralCategory --- --- 'Eq' instance: --- --- >>> UppercaseLetter == UppercaseLetter --- True --- >>> UppercaseLetter == LowercaseLetter --- False --- --- 'Ord' instance: --- --- >>> NonSpacingMark <= MathSymbol --- True --- --- 'Enum' instance: --- --- >>> enumFromTo ModifierLetter SpacingCombiningMark --- [ModifierLetter,OtherLetter,NonSpacingMark,SpacingCombiningMark] --- --- 'Read' instance: --- --- >>> read "DashPunctuation" :: GeneralCategory --- DashPunctuation --- >>> read "17" :: GeneralCategory --- *** Exception: Prelude.read: no parse --- --- 'Show' instance: --- --- >>> show EnclosingMark --- "EnclosingMark" --- --- 'Bounded' instance: --- --- >>> minBound :: GeneralCategory --- UppercaseLetter --- >>> maxBound :: GeneralCategory --- NotAssigned --- --- 'Ix' instance: --- --- >>> import Data.Ix ( index ) --- >>> index (OtherLetter,Control) FinalQuote --- 12 --- >>> index (OtherLetter,Control) Format --- *** Exception: Error in array index --- -data GeneralCategory - = UppercaseLetter -- ^ Lu: Letter, Uppercase - | LowercaseLetter -- ^ Ll: Letter, Lowercase - | TitlecaseLetter -- ^ Lt: Letter, Titlecase - | ModifierLetter -- ^ Lm: Letter, Modifier - | OtherLetter -- ^ Lo: Letter, Other - | NonSpacingMark -- ^ Mn: Mark, Non-Spacing - | SpacingCombiningMark -- ^ Mc: Mark, Spacing Combining - | EnclosingMark -- ^ Me: Mark, Enclosing - | DecimalNumber -- ^ Nd: Number, Decimal - | LetterNumber -- ^ Nl: Number, Letter - | OtherNumber -- ^ No: Number, Other - | ConnectorPunctuation -- ^ Pc: Punctuation, Connector - | DashPunctuation -- ^ Pd: Punctuation, Dash - | OpenPunctuation -- ^ Ps: Punctuation, Open - | ClosePunctuation -- ^ Pe: Punctuation, Close - | InitialQuote -- ^ Pi: Punctuation, Initial quote - | FinalQuote -- ^ Pf: Punctuation, Final quote - | OtherPunctuation -- ^ Po: Punctuation, Other - | MathSymbol -- ^ Sm: Symbol, Math - | CurrencySymbol -- ^ Sc: Symbol, Currency - | ModifierSymbol -- ^ Sk: Symbol, Modifier - | OtherSymbol -- ^ So: Symbol, Other - | Space -- ^ Zs: Separator, Space - | LineSeparator -- ^ Zl: Separator, Line - | ParagraphSeparator -- ^ Zp: Separator, Paragraph - | Control -- ^ Cc: Other, Control - | Format -- ^ Cf: Other, Format - | Surrogate -- ^ Cs: Other, Surrogate - | PrivateUse -- ^ Co: Other, Private Use - | NotAssigned -- ^ Cn: Other, Not Assigned - deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix) - --- | The Unicode general category of the character. This relies on the --- 'Enum' instance of 'GeneralCategory', which must remain in the --- same order as the categories are presented in the Unicode --- standard. --- --- ==== __Examples__ --- --- Basic usage: --- --- >>> generalCategory 'a' --- LowercaseLetter --- >>> generalCategory 'A' --- UppercaseLetter --- >>> generalCategory '0' --- DecimalNumber --- >>> generalCategory '%' --- OtherPunctuation --- >>> generalCategory '♥' --- OtherSymbol --- >>> generalCategory '\31' --- Control --- >>> generalCategory ' ' --- Space --- -generalCategory :: Char -> GeneralCategory -generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c - -- derived character classifiers -- | Selects alphabetic Unicode characters (lower-case, upper-case and @@ -358,96 +241,6 @@ DecimalNumber -> True LetterNumber -> True OtherNumber -> True - _ -> False - --- | Selects Unicode punctuation characters, including various kinds --- of connectors, brackets and quotes. --- --- This function returns 'True' if its argument has one of the --- following 'GeneralCategory's, or 'False' otherwise: --- --- * 'ConnectorPunctuation' --- * 'DashPunctuation' --- * 'OpenPunctuation' --- * 'ClosePunctuation' --- * 'InitialQuote' --- * 'FinalQuote' --- * 'OtherPunctuation' --- --- These classes are defined in the --- , --- part of the Unicode standard. The same document defines what is --- and is not a \"Punctuation\". --- --- ==== __Examples__ --- --- Basic usage: --- --- >>> isPunctuation 'a' --- False --- >>> isPunctuation '7' --- False --- >>> isPunctuation '♥' --- False --- >>> isPunctuation '"' --- True --- >>> isPunctuation '?' --- True --- >>> isPunctuation '—' --- True --- -isPunctuation :: Char -> Bool -isPunctuation c = case generalCategory c of - ConnectorPunctuation -> True - DashPunctuation -> True - OpenPunctuation -> True - ClosePunctuation -> True - InitialQuote -> True - FinalQuote -> True - OtherPunctuation -> True - _ -> False - --- | Selects Unicode symbol characters, including mathematical and --- currency symbols. --- --- This function returns 'True' if its argument has one of the --- following 'GeneralCategory's, or 'False' otherwise: --- --- * 'MathSymbol' --- * 'CurrencySymbol' --- * 'ModifierSymbol' --- * 'OtherSymbol' --- --- These classes are defined in the --- , --- part of the Unicode standard. The same document defines what is --- and is not a \"Symbol\". --- --- ==== __Examples__ --- --- Basic usage: --- --- >>> isSymbol 'a' --- False --- >>> isSymbol '6' --- False --- >>> isSymbol '=' --- True --- --- The definition of \"math symbol\" may be a little --- counter-intuitive depending on one's background: --- --- >>> isSymbol '+' --- True --- >>> isSymbol '-' --- False --- -isSymbol :: Char -> Bool -isSymbol c = case generalCategory c of - MathSymbol -> True - CurrencySymbol -> True - ModifierSymbol -> True - OtherSymbol -> True _ -> False -- | Selects Unicode space and separator characters. diff --git a/Data/Coerce.hs b/Data/Coerce.hs --- a/Data/Coerce.hs +++ b/Data/Coerce.hs @@ -26,5 +26,4 @@ import GHC.Prim (coerce) import GHC.Types (Coercible) -import GHC.Base () -- for build ordering - +import GHC.Base () -- for build ordering; see Notes in GHC.Base for more info diff --git a/Data/Complex.hs b/Data/Complex.hs --- a/Data/Complex.hs +++ b/Data/Complex.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- -- | @@ -34,7 +36,8 @@ ) where -import Data.Typeable +import GHC.Generics (Generic, Generic1) +import GHC.Float (Floating(..)) import Data.Data (Data) import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf, alignment) @@ -49,10 +52,13 @@ -- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@, -- but oriented in the positive real direction, whereas @'signum' z@ -- has the phase of @z@, but unit magnitude. +-- +-- The 'Foldable' and 'Traversable' instances traverse the real part first. data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. - deriving (Eq, Show, Read, Data, Typeable) + deriving (Eq, Show, Read, Data, Generic, Generic1 + , Functor, Foldable, Traversable) -- ----------------------------------------------------------------------------- -- Functions over Complex @@ -140,6 +146,22 @@ where expx = exp x log z = log (magnitude z) :+ phase z + x ** y = case (x,y) of + (_ , (0:+0)) -> 1 :+ 0 + ((0:+0), (exp_re:+_)) -> case compare exp_re 0 of + GT -> 0 :+ 0 + LT -> inf :+ 0 + EQ -> nan :+ nan + ((re:+im), (exp_re:+_)) + | (isInfinite re || isInfinite im) -> case compare exp_re 0 of + GT -> inf :+ 0 + LT -> 0 :+ 0 + EQ -> nan :+ nan + | otherwise -> exp (log x * y) + where + inf = 1/0 + nan = 0/0 + sqrt (0:+0) = 0 sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) where (u,v) = if x < 0 then (v',u') else (u',v') @@ -174,6 +196,20 @@ acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) atanh z = 0.5 * log ((1.0+z) / (1.0-z)) + log1p x@(a :+ b) + | abs a < 0.5 && abs b < 0.5 + , u <- 2*a + a*a + b*b = log1p (u/(1 + sqrt(u+1))) :+ atan2 (1 + a) b + | otherwise = log (1 + x) + {-# INLINE log1p #-} + + expm1 x@(a :+ b) + | a*a + b*b < 1 + , u <- expm1 a + , v <- sin (b/2) + , w <- -2*v*v = (u*w + u + w) :+ (u+1)*sin b + | otherwise = exp x - 1 + {-# INLINE expm1 #-} + instance Storable a => Storable (Complex a) where sizeOf a = 2 * sizeOf (realPart a) alignment a = alignment (realPart a) @@ -186,3 +222,10 @@ q <-return $ (castPtr p) poke q r pokeElemOff q 1 i + +instance Applicative Complex where + pure a = a :+ a + f :+ g <*> a :+ b = f a :+ g b + +instance Monad Complex where + a :+ b >>= f = realPart (f a) :+ imagPart (f b) diff --git a/Data/Data.hs b/Data/Data.hs --- a/Data/Data.hs +++ b/Data/Data.hs @@ -1,7 +1,9 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables, PolyKinds, StandaloneDeriving, - AutoDeriveTypeable, TypeOperators, GADTs, FlexibleInstances #-} + TypeOperators, GADTs, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -109,10 +111,11 @@ import Data.Either import Data.Eq import Data.Maybe +import Data.Monoid import Data.Ord import Data.Typeable import Data.Version( Version(..) ) -import GHC.Base +import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num import GHC.Read @@ -131,7 +134,9 @@ --import GHC.ST -- So we can give Data instance for ST --import GHC.Conc -- So we can give Data instance for MVar & Co. import GHC.Arr -- So we can give Data instance for Array - +import qualified GHC.Generics as Generics (Fixity(..)) +import GHC.Generics hiding (Fixity(..)) + -- So we can give Data instance for U1, V1, ... ------------------------------------------------------------------------------ -- @@ -442,7 +447,7 @@ -- | Build a term skeleton fromConstr :: Data a => Constr -> a -fromConstr = fromConstrB (error "Data.Data.fromConstr") +fromConstr = fromConstrB (errorWithoutStackTrace "Data.Data.fromConstr") -- | Build a term and use a generic function for subterms @@ -580,7 +585,7 @@ (IntRep, IntConstr i) -> mkIntegralConstr dt i (FloatRep, FloatConstr f) -> mkRealConstr dt f (CharRep, CharConstr c) -> mkCharConstr dt c - _ -> error "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType." + _ -> errorWithoutStackTrace "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType." @@ -618,7 +623,7 @@ dataTypeConstrs :: DataType -> [Constr] dataTypeConstrs dt = case datarep dt of (AlgRep cons) -> cons - _ -> error $ "Data.Data.dataTypeConstrs is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.dataTypeConstrs is not supported for " ++ dataTypeName dt ++ ", as it is not an algebraic data type." @@ -693,7 +698,7 @@ indexConstr :: DataType -> ConIndex -> Constr indexConstr dt idx = case datarep dt of (AlgRep cs) -> cs !! (idx-1) - _ -> error $ "Data.Data.indexConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.indexConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an algebraic data type." @@ -702,7 +707,7 @@ constrIndex :: Constr -> ConIndex constrIndex con = case constrRep con of (AlgConstr idx) -> idx - _ -> error $ "Data.Data.constrIndex is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.constrIndex is not supported for " ++ dataTypeName (constrType con) ++ ", as it is not an algebraic data type." @@ -711,7 +716,7 @@ maxConstrIndex :: DataType -> ConIndex maxConstrIndex dt = case dataTypeRep dt of AlgRep cs -> length cs - _ -> error $ "Data.Data.maxConstrIndex is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.maxConstrIndex is not supported for " ++ dataTypeName dt ++ ", as it is not an algebraic data type." @@ -753,21 +758,21 @@ { datatype = dt , conrep = cr , constring = str - , confields = error "Data.Data.confields" - , confixity = error "Data.Data.confixity" + , confields = errorWithoutStackTrace "Data.Data.confields" + , confixity = errorWithoutStackTrace "Data.Data.confixity" } mkIntegralConstr :: (Integral a, Show a) => DataType -> a -> Constr mkIntegralConstr dt i = case datarep dt of IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger i)) - _ -> error $ "Data.Data.mkIntegralConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.mkIntegralConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an Integral data type." mkRealConstr :: (Real a, Show a) => DataType -> a -> Constr mkRealConstr dt f = case datarep dt of FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f)) - _ -> error $ "Data.Data.mkRealConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.mkRealConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an Real data type." @@ -775,7 +780,7 @@ mkCharConstr :: DataType -> Char -> Constr mkCharConstr dt c = case datarep dt of CharRep -> mkPrimCon dt (show c) (CharConstr c) - _ -> error $ "Data.Data.mkCharConstr is not supported for " + _ -> errorWithoutStackTrace $ "Data.Data.mkCharConstr is not supported for " ++ dataTypeName dt ++ ", as it is not an Char data type." @@ -854,7 +859,7 @@ gunfold _ z c = case constrIndex c of 1 -> z False 2 -> z True - _ -> error $ "Data.Data.gunfold: Constructor " + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Bool." dataTypeOf _ = boolDataType @@ -869,7 +874,7 @@ toConstr x = mkCharConstr charType x gunfold _ z c = case constrRep c of (CharConstr x) -> z x - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Char." dataTypeOf _ = charType @@ -883,7 +888,7 @@ toConstr = mkRealConstr floatType gunfold _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Float." dataTypeOf _ = floatType @@ -897,7 +902,7 @@ toConstr = mkRealConstr doubleType gunfold _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Double." dataTypeOf _ = doubleType @@ -911,7 +916,7 @@ toConstr x = mkIntegralConstr intType x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int." dataTypeOf _ = intType @@ -925,7 +930,7 @@ toConstr = mkIntegralConstr integerType gunfold _ z c = case constrRep c of (IntConstr x) -> z x - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Integer." dataTypeOf _ = integerType @@ -939,7 +944,7 @@ toConstr x = mkIntegralConstr int8Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int8." dataTypeOf _ = int8Type @@ -953,7 +958,7 @@ toConstr x = mkIntegralConstr int16Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int16." dataTypeOf _ = int16Type @@ -967,7 +972,7 @@ toConstr x = mkIntegralConstr int32Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int32." dataTypeOf _ = int32Type @@ -981,7 +986,7 @@ toConstr x = mkIntegralConstr int64Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Int64." dataTypeOf _ = int64Type @@ -995,7 +1000,7 @@ toConstr x = mkIntegralConstr wordType x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word" dataTypeOf _ = wordType @@ -1009,7 +1014,7 @@ toConstr x = mkIntegralConstr word8Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word8." dataTypeOf _ = word8Type @@ -1023,7 +1028,7 @@ toConstr x = mkIntegralConstr word16Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word16." dataTypeOf _ = word16Type @@ -1037,7 +1042,7 @@ toConstr x = mkIntegralConstr word32Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word32." dataTypeOf _ = word32Type @@ -1051,7 +1056,7 @@ toConstr x = mkIntegralConstr word64Type x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Word64." dataTypeOf _ = word64Type @@ -1068,7 +1073,7 @@ gfoldl k z (a :% b) = z (%) `k` a `k` b toConstr _ = ratioConstr gunfold k z c | constrIndex c == 1 = k (k (z (%))) - gunfold _ _ _ = error "Data.Data.gunfold(Ratio)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ratio)" dataTypeOf _ = ratioDataType @@ -1090,7 +1095,7 @@ gunfold k z c = case constrIndex c of 1 -> z [] 2 -> k (k (z (:))) - _ -> error "Data.Data.gunfold(List)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(List)" dataTypeOf _ = listDataType dataCast1 f = gcast1 f @@ -1124,7 +1129,7 @@ gunfold k z c = case constrIndex c of 1 -> z Nothing 2 -> k (z Just) - _ -> error "Data.Data.gunfold(Maybe)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Maybe)" dataTypeOf _ = maybeDataType dataCast1 f = gcast1 f @@ -1152,7 +1157,7 @@ 1 -> z LT 2 -> z EQ 3 -> z GT - _ -> error "Data.Data.gunfold(Ordering)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Ordering)" dataTypeOf _ = orderingDataType @@ -1175,7 +1180,7 @@ gunfold k z c = case constrIndex c of 1 -> k (z Left) 2 -> k (z Right) - _ -> error "Data.Data.gunfold(Either)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Either)" dataTypeOf _ = eitherDataType dataCast2 f = gcast2 f @@ -1191,7 +1196,7 @@ instance Data () where toConstr () = tuple0Constr gunfold _ z c | constrIndex c == 1 = z () - gunfold _ _ _ = error "Data.Data.gunfold(unit)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(unit)" dataTypeOf _ = tuple0DataType @@ -1207,7 +1212,7 @@ gfoldl f z (a,b) = z (,) `f` a `f` b toConstr (_,_) = tuple2Constr gunfold k z c | constrIndex c == 1 = k (k (z (,))) - gunfold _ _ _ = error "Data.Data.gunfold(tup2)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(tup2)" dataTypeOf _ = tuple2DataType dataCast2 f = gcast2 f @@ -1224,7 +1229,7 @@ gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c toConstr (_,_,_) = tuple3Constr gunfold k z c | constrIndex c == 1 = k (k (k (z (,,)))) - gunfold _ _ _ = error "Data.Data.gunfold(tup3)" + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(tup3)" dataTypeOf _ = tuple3DataType @@ -1242,7 +1247,7 @@ toConstr (_,_,_,_) = tuple4Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (z (,,,))))) - _ -> error "Data.Data.gunfold(tup4)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup4)" dataTypeOf _ = tuple4DataType @@ -1260,7 +1265,7 @@ toConstr (_,_,_,_,_) = tuple5Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (z (,,,,)))))) - _ -> error "Data.Data.gunfold(tup5)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup5)" dataTypeOf _ = tuple5DataType @@ -1278,7 +1283,7 @@ toConstr (_,_,_,_,_,_) = tuple6Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (k (z (,,,,,))))))) - _ -> error "Data.Data.gunfold(tup6)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup6)" dataTypeOf _ = tuple6DataType @@ -1297,34 +1302,34 @@ toConstr (_,_,_,_,_,_,_) = tuple7Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) - _ -> error "Data.Data.gunfold(tup7)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(tup7)" dataTypeOf _ = tuple7DataType ------------------------------------------------------------------------------ -instance (Data a, Typeable a) => Data (Ptr a) where - toConstr _ = error "Data.Data.toConstr(Ptr)" - gunfold _ _ = error "Data.Data.gunfold(Ptr)" +instance Data a => Data (Ptr a) where + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(Ptr)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ptr)" dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr" dataCast1 x = gcast1 x ------------------------------------------------------------------------------ -instance (Data a, Typeable a) => Data (ForeignPtr a) where - toConstr _ = error "Data.Data.toConstr(ForeignPtr)" - gunfold _ _ = error "Data.Data.gunfold(ForeignPtr)" +instance Data a => Data (ForeignPtr a) where + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(ForeignPtr)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(ForeignPtr)" dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr" dataCast1 x = gcast1 x ------------------------------------------------------------------------------ -- The Data instance for Array preserves data abstraction at the cost of -- inefficiency. We omit reflection services for the sake of data abstraction. -instance (Typeable a, Data a, Data b, Ix a) => Data (Array a b) +instance (Data a, Data b, Ix a) => Data (Array a b) where gfoldl f z a = z (listArray (bounds a)) `f` (elems a) - toConstr _ = error "Data.Data.toConstr(Array)" - gunfold _ _ = error "Data.Data.gunfold(Array)" + toConstr _ = errorWithoutStackTrace "Data.Data.toConstr(Array)" + gunfold _ _ = errorWithoutStackTrace "Data.Data.gunfold(Array)" dataTypeOf _ = mkNoRepType "Data.Array.Array" dataCast2 x = gcast2 x @@ -1342,7 +1347,7 @@ toConstr Proxy = proxyConstr gunfold _ z c = case constrIndex c of 1 -> z Proxy - _ -> error "Data.Data.gunfold(Proxy)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Proxy)" dataTypeOf _ = proxyDataType dataCast1 f = gcast1 f @@ -1360,7 +1365,7 @@ toConstr Refl = reflConstr gunfold _ z c = case constrIndex c of 1 -> z Refl - _ -> error "Data.Data.gunfold(:~:)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(:~:)" dataTypeOf _ = equalityDataType dataCast2 f = gcast2 f @@ -1378,7 +1383,7 @@ toConstr Coercion = coercionConstr gunfold _ z c = case constrIndex c of 1 -> z Coercion - _ -> error "Data.Data.gunfold(Coercion)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Coercion)" dataTypeOf _ = coercionDataType dataCast2 f = gcast2 f @@ -1396,5 +1401,418 @@ toConstr (Version _ _) = versionConstr gunfold k z c = case constrIndex c of 1 -> k (k (z Version)) - _ -> error "Data.Data.gunfold(Version)" + _ -> errorWithoutStackTrace "Data.Data.gunfold(Version)" dataTypeOf _ = versionDataType + +----------------------------------------------------------------------- +-- instances for Data.Monoid wrappers + +dualConstr :: Constr +dualConstr = mkConstr dualDataType "Dual" ["getDual"] Prefix + +dualDataType :: DataType +dualDataType = mkDataType "Data.Monoid.Dual" [dualConstr] + +instance Data a => Data (Dual a) where + gfoldl f z (Dual x) = z Dual `f` x + gunfold k z _ = k (z Dual) + toConstr (Dual _) = dualConstr + dataTypeOf _ = dualDataType + dataCast1 f = gcast1 f + +allConstr :: Constr +allConstr = mkConstr allDataType "All" ["getAll"] Prefix + +allDataType :: DataType +allDataType = mkDataType "All" [allConstr] + +instance Data All where + gfoldl f z (All x) = (z All `f` x) + gunfold k z _ = k (z All) + toConstr (All _) = allConstr + dataTypeOf _ = allDataType + +anyConstr :: Constr +anyConstr = mkConstr anyDataType "Any" ["getAny"] Prefix + +anyDataType :: DataType +anyDataType = mkDataType "Any" [anyConstr] + +instance Data Any where + gfoldl f z (Any x) = (z Any `f` x) + gunfold k z _ = k (z Any) + toConstr (Any _) = anyConstr + dataTypeOf _ = anyDataType + + +sumConstr :: Constr +sumConstr = mkConstr sumDataType "Sum" ["getSum"] Prefix + +sumDataType :: DataType +sumDataType = mkDataType "Data.Monoid.Sum" [sumConstr] + +instance Data a => Data (Sum a) where + gfoldl f z (Sum x) = z Sum `f` x + gunfold k z _ = k (z Sum) + toConstr (Sum _) = sumConstr + dataTypeOf _ = sumDataType + dataCast1 f = gcast1 f + + +productConstr :: Constr +productConstr = mkConstr productDataType "Product" ["getProduct"] Prefix + +productDataType :: DataType +productDataType = mkDataType "Data.Monoid.Product" [productConstr] + +instance Data a => Data (Product a) where + gfoldl f z (Product x) = z Product `f` x + gunfold k z _ = k (z Product) + toConstr (Product _) = productConstr + dataTypeOf _ = productDataType + dataCast1 f = gcast1 f + + +firstConstr :: Constr +firstConstr = mkConstr firstDataType "First" ["getFirst"] Prefix + +firstDataType :: DataType +firstDataType = mkDataType "Data.Monoid.First" [firstConstr] + +instance Data a => Data (First a) where + gfoldl f z (First x) = (z First `f` x) + gunfold k z _ = k (z First) + toConstr (First _) = firstConstr + dataTypeOf _ = firstDataType + dataCast1 f = gcast1 f + + +lastConstr :: Constr +lastConstr = mkConstr lastDataType "Last" ["getLast"] Prefix + +lastDataType :: DataType +lastDataType = mkDataType "Data.Monoid.Last" [lastConstr] + +instance Data a => Data (Last a) where + gfoldl f z (Last x) = (z Last `f` x) + gunfold k z _ = k (z Last) + toConstr (Last _) = lastConstr + dataTypeOf _ = lastDataType + dataCast1 f = gcast1 f + + +altConstr :: Constr +altConstr = mkConstr altDataType "Alt" ["getAlt"] Prefix + +altDataType :: DataType +altDataType = mkDataType "Alt" [altConstr] + +instance (Data (f a), Data a, Typeable f) => Data (Alt f a) where + gfoldl f z (Alt x) = (z Alt `f` x) + gunfold k z _ = k (z Alt) + toConstr (Alt _) = altConstr + dataTypeOf _ = altDataType + +----------------------------------------------------------------------- +-- instances for GHC.Generics + +u1Constr :: Constr +u1Constr = mkConstr u1DataType "U1" [] Prefix + +u1DataType :: DataType +u1DataType = mkDataType "GHC.Generics.U1" [u1Constr] + +instance Data p => Data (U1 p) where + gfoldl _ z U1 = z U1 + toConstr U1 = u1Constr + gunfold _ z c = case constrIndex c of + 1 -> z U1 + _ -> errorWithoutStackTrace "Data.Data.gunfold(U1)" + dataTypeOf _ = u1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +par1Constr :: Constr +par1Constr = mkConstr par1DataType "Par1" [] Prefix + +par1DataType :: DataType +par1DataType = mkDataType "GHC.Generics.Par1" [par1Constr] + +instance Data p => Data (Par1 p) where + gfoldl k z (Par1 p) = z Par1 `k` p + toConstr (Par1 _) = par1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z Par1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Par1)" + dataTypeOf _ = par1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +rec1Constr :: Constr +rec1Constr = mkConstr rec1DataType "Rec1" [] Prefix + +rec1DataType :: DataType +rec1DataType = mkDataType "GHC.Generics.Rec1" [rec1Constr] + +instance (Data (f p), Typeable f, Data p) => Data (Rec1 f p) where + gfoldl k z (Rec1 p) = z Rec1 `k` p + toConstr (Rec1 _) = rec1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z Rec1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Rec1)" + dataTypeOf _ = rec1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +k1Constr :: Constr +k1Constr = mkConstr k1DataType "K1" [] Prefix + +k1DataType :: DataType +k1DataType = mkDataType "GHC.Generics.K1" [k1Constr] + +instance (Typeable i, Data p, Data c) => Data (K1 i c p) where + gfoldl k z (K1 p) = z K1 `k` p + toConstr (K1 _) = k1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z K1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(K1)" + dataTypeOf _ = k1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +m1Constr :: Constr +m1Constr = mkConstr m1DataType "M1" [] Prefix + +m1DataType :: DataType +m1DataType = mkDataType "GHC.Generics.M1" [m1Constr] + +instance (Data p, Data (f p), Typeable c, Typeable i, Typeable f) + => Data (M1 i c f p) where + gfoldl k z (M1 p) = z M1 `k` p + toConstr (M1 _) = m1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z M1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(M1)" + dataTypeOf _ = m1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +sum1DataType :: DataType +sum1DataType = mkDataType "GHC.Generics.:+:" [l1Constr, r1Constr] + +l1Constr :: Constr +l1Constr = mkConstr sum1DataType "L1" [] Prefix + +r1Constr :: Constr +r1Constr = mkConstr sum1DataType "R1" [] Prefix + +instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p)) + => Data ((f :+: g) p) where + gfoldl k z (L1 a) = z L1 `k` a + gfoldl k z (R1 a) = z R1 `k` a + toConstr L1{} = l1Constr + toConstr R1{} = r1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z L1) + 2 -> k (z R1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(:+:)" + dataTypeOf _ = sum1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +comp1Constr :: Constr +comp1Constr = mkConstr comp1DataType "Comp1" [] Prefix + +comp1DataType :: DataType +comp1DataType = mkDataType "GHC.Generics.:.:" [comp1Constr] + +instance (Typeable f, Typeable g, Data p, Data (f (g p))) + => Data ((f :.: g) p) where + gfoldl k z (Comp1 c) = z Comp1 `k` c + toConstr (Comp1 _) = m1Constr + gunfold k z c = case constrIndex c of + 1 -> k (z Comp1) + _ -> errorWithoutStackTrace "Data.Data.gunfold(:.:)" + dataTypeOf _ = comp1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +v1DataType :: DataType +v1DataType = mkDataType "GHC.Generics.V1" [] + +instance Data p => Data (V1 p) where + gfoldl _ _ !_ = undefined + toConstr !_ = undefined + gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(V1)" + dataTypeOf _ = v1DataType + dataCast1 f = gcast1 f + +----------------------------------------------------------------------- + +prod1DataType :: DataType +prod1DataType = mkDataType "GHC.Generics.:*:" [prod1Constr] + +prod1Constr :: Constr +prod1Constr = mkConstr prod1DataType "Prod1" [] Infix + +instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p)) + => Data ((f :*: g) p) where + gfoldl k z (l :*: r) = z (:*:) `k` l `k` r + toConstr _ = prod1Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (z (:*:))) + _ -> errorWithoutStackTrace "Data.Data.gunfold(:*:)" + dataCast1 f = gcast1 f + dataTypeOf _ = prod1DataType + +----------------------------------------------------------------------- + +prefixConstr :: Constr +prefixConstr = mkConstr fixityDataType "Prefix" [] Prefix +infixConstr :: Constr +infixConstr = mkConstr fixityDataType "Infix" [] Prefix + +fixityDataType :: DataType +fixityDataType = mkDataType "GHC.Generics.Fixity" [prefixConstr,infixConstr] + +instance Data Generics.Fixity where + gfoldl _ z Generics.Prefix = z Generics.Prefix + gfoldl f z (Generics.Infix a i) = z Generics.Infix `f` a `f` i + toConstr Generics.Prefix = prefixConstr + toConstr Generics.Infix{} = infixConstr + gunfold k z c = case constrIndex c of + 1 -> z Generics.Prefix + 2 -> k (k (z Generics.Infix)) + _ -> errorWithoutStackTrace "Data.Data.gunfold(Fixity)" + dataTypeOf _ = fixityDataType + +----------------------------------------------------------------------- + +leftAssociativeConstr :: Constr +leftAssociativeConstr + = mkConstr associativityDataType "LeftAssociative" [] Prefix +rightAssociativeConstr :: Constr +rightAssociativeConstr + = mkConstr associativityDataType "RightAssociative" [] Prefix +notAssociativeConstr :: Constr +notAssociativeConstr + = mkConstr associativityDataType "NotAssociative" [] Prefix + +associativityDataType :: DataType +associativityDataType = mkDataType "GHC.Generics.Associativity" + [leftAssociativeConstr,rightAssociativeConstr,notAssociativeConstr] + +instance Data Associativity where + gfoldl _ z LeftAssociative = z LeftAssociative + gfoldl _ z RightAssociative = z RightAssociative + gfoldl _ z NotAssociative = z NotAssociative + toConstr LeftAssociative = leftAssociativeConstr + toConstr RightAssociative = rightAssociativeConstr + toConstr NotAssociative = notAssociativeConstr + gunfold _ z c = case constrIndex c of + 1 -> z LeftAssociative + 2 -> z RightAssociative + 3 -> z NotAssociative + _ -> errorWithoutStackTrace + "Data.Data.gunfold(Associativity)" + dataTypeOf _ = associativityDataType + +----------------------------------------------------------------------- + +noSourceUnpackednessConstr :: Constr +noSourceUnpackednessConstr + = mkConstr sourceUnpackednessDataType "NoSourceUnpackedness" [] Prefix +sourceNoUnpackConstr :: Constr +sourceNoUnpackConstr + = mkConstr sourceUnpackednessDataType "SourceNoUnpack" [] Prefix +sourceUnpackConstr :: Constr +sourceUnpackConstr + = mkConstr sourceUnpackednessDataType "SourceUnpack" [] Prefix + +sourceUnpackednessDataType :: DataType +sourceUnpackednessDataType = mkDataType "GHC.Generics.SourceUnpackedness" + [noSourceUnpackednessConstr,sourceNoUnpackConstr,sourceUnpackConstr] + +instance Data SourceUnpackedness where + gfoldl _ z NoSourceUnpackedness = z NoSourceUnpackedness + gfoldl _ z SourceNoUnpack = z SourceNoUnpack + gfoldl _ z SourceUnpack = z SourceUnpack + toConstr NoSourceUnpackedness = noSourceUnpackednessConstr + toConstr SourceNoUnpack = sourceNoUnpackConstr + toConstr SourceUnpack = sourceUnpackConstr + gunfold _ z c = case constrIndex c of + 1 -> z NoSourceUnpackedness + 2 -> z SourceNoUnpack + 3 -> z SourceUnpack + _ -> errorWithoutStackTrace + "Data.Data.gunfold(SourceUnpackedness)" + dataTypeOf _ = sourceUnpackednessDataType + +----------------------------------------------------------------------- + +noSourceStrictnessConstr :: Constr +noSourceStrictnessConstr + = mkConstr sourceStrictnessDataType "NoSourceStrictness" [] Prefix +sourceLazyConstr :: Constr +sourceLazyConstr + = mkConstr sourceStrictnessDataType "SourceLazy" [] Prefix +sourceStrictConstr :: Constr +sourceStrictConstr + = mkConstr sourceStrictnessDataType "SourceStrict" [] Prefix + +sourceStrictnessDataType :: DataType +sourceStrictnessDataType = mkDataType "GHC.Generics.SourceStrictness" + [noSourceStrictnessConstr,sourceLazyConstr,sourceStrictConstr] + +instance Data SourceStrictness where + gfoldl _ z NoSourceStrictness = z NoSourceStrictness + gfoldl _ z SourceLazy = z SourceLazy + gfoldl _ z SourceStrict = z SourceStrict + toConstr NoSourceStrictness = noSourceStrictnessConstr + toConstr SourceLazy = sourceLazyConstr + toConstr SourceStrict = sourceStrictConstr + gunfold _ z c = case constrIndex c of + 1 -> z NoSourceStrictness + 2 -> z SourceLazy + 3 -> z SourceStrict + _ -> errorWithoutStackTrace + "Data.Data.gunfold(SourceStrictness)" + dataTypeOf _ = sourceStrictnessDataType + +----------------------------------------------------------------------- + +decidedLazyConstr :: Constr +decidedLazyConstr + = mkConstr decidedStrictnessDataType "DecidedLazy" [] Prefix +decidedStrictConstr :: Constr +decidedStrictConstr + = mkConstr decidedStrictnessDataType "DecidedStrict" [] Prefix +decidedUnpackConstr :: Constr +decidedUnpackConstr + = mkConstr decidedStrictnessDataType "DecidedUnpack" [] Prefix + +decidedStrictnessDataType :: DataType +decidedStrictnessDataType = mkDataType "GHC.Generics.DecidedStrictness" + [decidedLazyConstr,decidedStrictConstr,decidedUnpackConstr] + +instance Data DecidedStrictness where + gfoldl _ z DecidedLazy = z DecidedLazy + gfoldl _ z DecidedStrict = z DecidedStrict + gfoldl _ z DecidedUnpack = z DecidedUnpack + toConstr DecidedLazy = decidedLazyConstr + toConstr DecidedStrict = decidedStrictConstr + toConstr DecidedUnpack = decidedUnpackConstr + gunfold _ z c = case constrIndex c of + 1 -> z DecidedLazy + 2 -> z DecidedStrict + 3 -> z DecidedUnpack + _ -> errorWithoutStackTrace + "Data.Data.gunfold(DecidedStrictness)" + dataTypeOf _ = decidedStrictnessDataType diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -68,7 +68,6 @@ of the object\'s type; useful for debugging. -} data Dynamic = Dynamic TypeRep Obj - deriving Typeable instance Show Dynamic where -- the instance just prints the type representation. @@ -136,7 +135,7 @@ dynApp :: Dynamic -> Dynamic -> Dynamic dynApp f x = case dynApply f x of Just r -> r - Nothing -> error ("Type error in dynamic application.\n" ++ + Nothing -> errorWithoutStackTrace ("Type error in dynamic application.\n" ++ "Can't apply function " ++ show f ++ " to argument " ++ show x) diff --git a/Data/Either.hs b/Data/Either.hs --- a/Data/Either.hs +++ b/Data/Either.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, TypeOperators, UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -8,7 +8,7 @@ -- Module : Data.Either -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable @@ -31,7 +31,6 @@ import GHC.Show import GHC.Read -import Data.Typeable import Data.Type.Equality -- $setup @@ -123,7 +122,7 @@ -} data Either a b = Left a | Right b - deriving (Eq, Ord, Read, Show, Typeable) + deriving (Eq, Ord, Read, Show) instance Functor (Either a) where fmap _ (Left x) = Left x @@ -135,7 +134,6 @@ Right f <*> r = fmap f r instance Monad (Either e) where - return = Right Left l >>= _ = Left l Right r >>= k = k r @@ -283,7 +281,7 @@ type family EqEither a b where EqEither ('Left x) ('Left y) = x == y EqEither ('Right x) ('Right y) = x == y - EqEither a b = 'False + EqEither a b = 'False type instance a == b = EqEither a b {- diff --git a/Data/Fixed.hs b/Data/Fixed.hs --- a/Data/Fixed.hs +++ b/Data/Fixed.hs @@ -1,6 +1,5 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AutoDeriveTypeable #-} ----------------------------------------------------------------------------- -- | diff --git a/Data/Foldable.hs b/Data/Foldable.hs --- a/Data/Foldable.hs +++ b/Data/Foldable.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -56,11 +60,12 @@ import Data.Ord import Data.Proxy -import GHC.Arr ( Array(..), Ix(..), elems, numElements, +import GHC.Arr ( Array(..), elems, numElements, foldlElems, foldrElems, foldlElems', foldrElems', foldl1Elems, foldr1Elems) import GHC.Base hiding ( foldr ) +import GHC.Generics import GHC.Num ( Num(..) ) infix 4 `elem`, `notElem` @@ -119,32 +124,80 @@ -- | Map each element of the structure to a monoid, -- and combine the results. foldMap :: Monoid m => (a -> m) -> t a -> m + {-# INLINE foldMap #-} + -- This INLINE allows more list functions to fuse. See Trac #9848. foldMap f = foldr (mappend . f) mempty -- | Right-associative fold of a structure. -- - -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + -- In the case of lists, 'foldr', when applied to a binary operator, a + -- starting value (typically the right-identity of the operator), and a + -- list, reduces the list using the binary operator, from right to left: + -- + -- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) + -- + -- Note that, since the head of the resulting expression is produced by + -- an application of the operator to the first element of the list, + -- 'foldr' can produce a terminating expression from an infinite list. + -- + -- For a general 'Foldable' structure this should be semantically identical + -- to, + -- + -- @foldr f z = 'List.foldr' f z . 'toList'@ + -- foldr :: (a -> b -> b) -> b -> t a -> b foldr f z t = appEndo (foldMap (Endo #. f) t) z - -- | Right-associative fold of a structure, - -- but with strict application of the operator. + -- | Right-associative fold of a structure, but with strict application of + -- the operator. + -- foldr' :: (a -> b -> b) -> b -> t a -> b foldr' f z0 xs = foldl f' id xs z0 where f' k x z = k $! f x z -- | Left-associative fold of a structure. -- - -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + -- In the case of lists, 'foldl', when applied to a binary + -- operator, a starting value (typically the left-identity of the operator), + -- and a list, reduces the list using the binary operator, from left to + -- right: + -- + -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn + -- + -- Note that to produce the outermost application of the operator the + -- entire input list must be traversed. This means that 'foldl'' will + -- diverge if given an infinite list. + -- + -- Also note that if you want an efficient left-fold, you probably want to + -- use 'foldl'' instead of 'foldl'. The reason for this is that latter does + -- not force the "inner" results (e.g. @z `f` x1@ in the above example) + -- before applying them to the operator (e.g. to @(`f` x2)@). This results + -- in a thunk chain @O(n)@ elements long, which then must be evaluated from + -- the outside-in. + -- + -- For a general 'Foldable' structure this should be semantically identical + -- to, + -- + -- @foldl f z = 'List.foldl' f z . 'toList'@ + -- foldl :: (b -> a -> b) -> b -> t a -> b foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z -- There's no point mucking around with coercions here, -- because flip forces us to build a new function anyway. - -- | Left-associative fold of a structure. - -- but with strict application of the operator. + -- | Left-associative fold of a structure but with strict application of + -- the operator. -- - -- @'foldl' f z = 'List.foldl'' f z . 'toList'@ + -- This ensures that each step of the fold is forced to weak head normal + -- form before being applied, avoiding the collection of thunks that would + -- otherwise occur. This is often what you want to strictly reduce a finite + -- list to a single, monolithic result (e.g. 'length'). + -- + -- For a general 'Foldable' structure this should be semantically identical + -- to, + -- + -- @foldl f z = 'List.foldl'' f z . 'toList'@ + -- foldl' :: (b -> a -> b) -> b -> t a -> b foldl' f z0 xs = foldr f' id xs z0 where f' x k z = k $! f z x @@ -152,9 +205,9 @@ -- | A variant of 'foldr' that has no base case, -- and thus may only be applied to non-empty structures. -- - -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + -- @'foldr1' f = 'List.foldr1' f . 'toList'@ foldr1 :: (a -> a -> a) -> t a -> a - foldr1 f xs = fromMaybe (error "foldr1: empty structure") + foldr1 f xs = fromMaybe (errorWithoutStackTrace "foldr1: empty structure") (foldr mf Nothing xs) where mf x m = Just (case m of @@ -164,9 +217,9 @@ -- | A variant of 'foldl' that has no base case, -- and thus may only be applied to non-empty structures. -- - -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + -- @'foldl1' f = 'List.foldl1' f . 'toList'@ foldl1 :: (a -> a -> a) -> t a -> a - foldl1 f xs = fromMaybe (error "foldl1: empty structure") + foldl1 f xs = fromMaybe (errorWithoutStackTrace "foldl1: empty structure") (foldl mf Nothing xs) where mf m y = Just (case m of @@ -196,12 +249,12 @@ -- | The largest element of a non-empty structure. maximum :: forall a . Ord a => t a -> a - maximum = fromMaybe (error "maximum: empty structure") . + maximum = fromMaybe (errorWithoutStackTrace "maximum: empty structure") . getMax . foldMap (Max #. (Just :: a -> Maybe a)) -- | The least element of a non-empty structure. minimum :: forall a . Ord a => t a -> a - minimum = fromMaybe (error "minimum: empty structure") . + minimum = fromMaybe (errorWithoutStackTrace "minimum: empty structure") . getMin . foldMap (Min #. (Just :: a -> Maybe a)) -- | The 'sum' function computes the sum of the numbers of a structure. @@ -254,7 +307,7 @@ foldr f z (_, y) = f y z -instance Ix i => Foldable (Array i) where +instance Foldable (Array i) where foldr = foldrElems foldl = foldlElems foldl' = foldlElems' @@ -274,14 +327,74 @@ {-# INLINE foldr #-} foldl _ z _ = z {-# INLINE foldl #-} - foldl1 _ _ = error "foldl1: Proxy" - foldr1 _ _ = error "foldr1: Proxy" + foldl1 _ _ = errorWithoutStackTrace "foldl1: Proxy" + foldr1 _ _ = errorWithoutStackTrace "foldr1: Proxy" length _ = 0 null _ = True elem _ _ = False sum _ = 0 product _ = 1 +instance Foldable Dual where + foldMap = coerce + + elem = (. getDual) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = getDual + foldr f z (Dual x) = f x z + foldr' = foldr + foldr1 _ = getDual + length _ = 1 + maximum = getDual + minimum = getDual + null _ = False + product = getDual + sum = getDual + toList (Dual x) = [x] + +instance Foldable Sum where + foldMap = coerce + + elem = (. getSum) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = getSum + foldr f z (Sum x) = f x z + foldr' = foldr + foldr1 _ = getSum + length _ = 1 + maximum = getSum + minimum = getSum + null _ = False + product = getSum + sum = getSum + toList (Sum x) = [x] + +instance Foldable Product where + foldMap = coerce + + elem = (. getProduct) #. (==) + foldl = coerce + foldl' = coerce + foldl1 _ = getProduct + foldr f z (Product x) = f x z + foldr' = foldr + foldr1 _ = getProduct + length _ = 1 + maximum = getProduct + minimum = getProduct + null _ = False + product = getProduct + sum = getProduct + toList (Product x) = [x] + +instance Foldable First where + foldMap f = foldMap f . getFirst + +instance Foldable Last where + foldMap f = foldMap f . getLast + -- We don't export Max and Min because, as Edward Kmett pointed out to me, -- there are two reasonable ways to define them. One way is to use Maybe, as we -- do here; the other way is to impose a Bounded constraint on the Monoid @@ -310,6 +423,39 @@ (Min m@(Just x)) `mappend` (Min n@(Just y)) | x <= y = Min m | otherwise = Min n + +-- Instances for GHC.Generics +instance Foldable U1 where + foldMap _ _ = mempty + {-# INLINE foldMap #-} + fold _ = mempty + {-# INLINE fold #-} + foldr _ z _ = z + {-# INLINE foldr #-} + foldl _ z _ = z + {-# INLINE foldl #-} + foldl1 _ _ = errorWithoutStackTrace "foldl1: U1" + foldr1 _ _ = errorWithoutStackTrace "foldr1: U1" + length _ = 0 + null _ = True + elem _ _ = False + sum _ = 0 + product _ = 1 + +deriving instance Foldable V1 +deriving instance Foldable Par1 +deriving instance Foldable f => Foldable (Rec1 f) +deriving instance Foldable (K1 i c) +deriving instance Foldable f => Foldable (M1 i c f) +deriving instance (Foldable f, Foldable g) => Foldable (f :+: g) +deriving instance (Foldable f, Foldable g) => Foldable (f :*: g) +deriving instance (Foldable f, Foldable g) => Foldable (f :.: g) +deriving instance Foldable UAddr +deriving instance Foldable UChar +deriving instance Foldable UDouble +deriving instance Foldable UFloat +deriving instance Foldable UInt +deriving instance Foldable UWord -- | Monadic fold over the elements of a structure, -- associating to the right, i.e. from right to left. diff --git a/Data/Functor.hs b/Data/Functor.hs --- a/Data/Functor.hs +++ b/Data/Functor.hs @@ -33,6 +33,15 @@ -- | An infix synonym for 'fmap'. -- +-- The name of this operator is an allusion to '$'. +-- Note the similarities between their types: +-- +-- > ($) :: (a -> b) -> a -> b +-- > (<$>) :: Functor f => (a -> b) -> f a -> f b +-- +-- Whereas '$' is function application, '<$>' is function +-- application lifted over a 'Functor'. +-- -- ==== __Examples__ -- -- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show': diff --git a/Data/Functor/Classes.hs b/Data/Functor/Classes.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Classes.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Classes +-- Copyright : (c) Ross Paterson 2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to +-- unary and binary type constructors. +-- +-- These classes are needed to express the constraints on arguments of +-- transformers in portable Haskell. Thus for a new transformer @T@, +-- one might write instances like +-- +-- > instance (Eq1 f) => Eq1 (T f) where ... +-- > instance (Ord1 f) => Ord1 (T f) where ... +-- > instance (Read1 f) => Read1 (T f) where ... +-- > instance (Show1 f) => Show1 (T f) where ... +-- +-- If these instances can be defined, defining instances of the base +-- classes is mechanical: +-- +-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 +-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 +-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 +-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Classes ( + -- * Liftings of Prelude classes + -- ** For unary constructors + Eq1(..), eq1, + Ord1(..), compare1, + Read1(..), readsPrec1, + Show1(..), showsPrec1, + -- ** For binary constructors + Eq2(..), eq2, + Ord2(..), compare2, + Read2(..), readsPrec2, + Show2(..), showsPrec2, + -- * Helper functions + -- $example + readsData, + readsUnaryWith, + readsBinaryWith, + showsUnaryWith, + showsBinaryWith, + -- ** Obsolete helpers + readsUnary, + readsUnary1, + readsBinary1, + showsUnary, + showsUnary1, + showsBinary1, + ) where + +import Control.Applicative (Const(Const)) +import Data.Functor.Identity (Identity(Identity)) +import Data.Proxy (Proxy(Proxy)) +import Data.Monoid (mappend) +import Text.Show (showListWith) + +-- | Lifting of the 'Eq' class to unary type constructors. +class Eq1 f where + -- | Lift an equality test through the type constructor. + -- + -- The function will usually be applied to an equality function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool + +-- | Lift the standard @('==')@ function through the type constructor. +eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool +eq1 = liftEq (==) + +-- | Lifting of the 'Ord' class to unary type constructors. +class (Eq1 f) => Ord1 f where + -- | Lift a 'compare' function through the type constructor. + -- + -- The function will usually be applied to a comparison function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering + +-- | Lift the standard 'compare' function through the type constructor. +compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering +compare1 = liftCompare compare + +-- | Lifting of the 'Read' class to unary type constructors. +class Read1 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] + liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) + +-- | Read a list (using square brackets and commas), given a function +-- for reading elements. +readListWith :: ReadS a -> ReadS [a] +readListWith rp = + readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) + where + readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] + +-- | Lift the standard 'readsPrec' and 'readList' functions through the +-- type constructor. +readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) +readsPrec1 = liftReadsPrec readsPrec readList + +-- | Lifting of the 'Show' class to unary type constructors. +class Show1 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + Int -> f a -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + [f a] -> ShowS + liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) + +-- | Lift the standard 'showsPrec' and 'showList' functions through the +-- type constructor. +showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS +showsPrec1 = liftShowsPrec showsPrec showList + +-- | Lifting of the 'Eq' class to binary type constructors. +class Eq2 f where + -- | Lift equality tests through the type constructor. + -- + -- The function will usually be applied to equality functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool + +-- | Lift the standard @('==')@ function through the type constructor. +eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool +eq2 = liftEq2 (==) (==) + +-- | Lifting of the 'Ord' class to binary type constructors. +class (Eq2 f) => Ord2 f where + -- | Lift 'compare' functions through the type constructor. + -- + -- The function will usually be applied to comparison functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> + f a c -> f b d -> Ordering + +-- | Lift the standard 'compare' function through the type constructor. +compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering +compare2 = liftCompare2 compare compare + +-- | Lifting of the 'Read' class to binary type constructors. +class Read2 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] + liftReadList2 rp1 rl1 rp2 rl2 = + readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) + +-- | Lift the standard 'readsPrec' function through the type constructor. +readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) +readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList + +-- | Lifting of the 'Show' class to binary type constructors. +class Show2 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS + liftShowList2 sp1 sl1 sp2 sl2 = + showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) + +-- | Lift the standard 'showsPrec' function through the type constructor. +showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS +showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList + +-- Instances for Prelude type constructors + +instance Eq1 Maybe where + liftEq _ Nothing Nothing = True + liftEq _ Nothing (Just _) = False + liftEq _ (Just _) Nothing = False + liftEq eq (Just x) (Just y) = eq x y + +instance Ord1 Maybe where + liftCompare _ Nothing Nothing = EQ + liftCompare _ Nothing (Just _) = LT + liftCompare _ (Just _) Nothing = GT + liftCompare comp (Just x) (Just y) = comp x y + +instance Read1 Maybe where + liftReadsPrec rp _ d = + readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) + `mappend` + readsData (readsUnaryWith rp "Just" Just) d + +instance Show1 Maybe where + liftShowsPrec _ _ _ Nothing = showString "Nothing" + liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x + +instance Eq1 [] where + liftEq _ [] [] = True + liftEq _ [] (_:_) = False + liftEq _ (_:_) [] = False + liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys + +instance Ord1 [] where + liftCompare _ [] [] = EQ + liftCompare _ [] (_:_) = LT + liftCompare _ (_:_) [] = GT + liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys + +instance Read1 [] where + liftReadsPrec _ rl _ = rl + +instance Show1 [] where + liftShowsPrec _ sl _ = sl + +instance Eq2 (,) where + liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 + +instance Ord2 (,) where + liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = + comp1 x1 x2 `mappend` comp2 y1 y2 + +instance Read2 (,) where + liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> + [((x,y), w) | ("(",s) <- lex r, + (x,t) <- rp1 0 s, + (",",u) <- lex t, + (y,v) <- rp2 0 u, + (")",w) <- lex v] + +instance Show2 (,) where + liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = + showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' + +instance (Eq a) => Eq1 ((,) a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 ((,) a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 ((,) a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 ((,) a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Eq2 Either where + liftEq2 e1 _ (Left x) (Left y) = e1 x y + liftEq2 _ _ (Left _) (Right _) = False + liftEq2 _ _ (Right _) (Left _) = False + liftEq2 _ e2 (Right x) (Right y) = e2 x y + +instance Ord2 Either where + liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y + liftCompare2 _ _ (Left _) (Right _) = LT + liftCompare2 _ _ (Right _) (Left _) = GT + liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y + +instance Read2 Either where + liftReadsPrec2 rp1 _ rp2 _ = readsData $ + readsUnaryWith rp1 "Left" Left `mappend` + readsUnaryWith rp2 "Right" Right + +instance Show2 Either where + liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x + liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x + +instance (Eq a) => Eq1 (Either a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 (Either a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 (Either a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 (Either a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Instances for other functors defined in the base package + +instance Eq1 Identity where + liftEq eq (Identity x) (Identity y) = eq x y + +instance Ord1 Identity where + liftCompare comp (Identity x) (Identity y) = comp x y + +instance Read1 Identity where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Identity" Identity + +instance Show1 Identity where + liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x + +instance Eq2 Const where + liftEq2 eq _ (Const x) (Const y) = eq x y + +instance Ord2 Const where + liftCompare2 comp _ (Const x) (Const y) = comp x y + +instance Read2 Const where + liftReadsPrec2 rp _ _ _ = readsData $ + readsUnaryWith rp "Const" Const + +instance Show2 Const where + liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x + +instance (Eq a) => Eq1 (Const a) where + liftEq = liftEq2 (==) +instance (Ord a) => Ord1 (Const a) where + liftCompare = liftCompare2 compare +instance (Read a) => Read1 (Const a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Show a) => Show1 (Const a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Proxy unfortunately imports this module, hence these instances are placed +-- here, +-- | @since 4.9.0.0 +instance Eq1 Proxy where + liftEq _ _ _ = True + +-- | @since 4.9.0.0 +instance Ord1 Proxy where + liftCompare _ _ _ = EQ + +-- | @since 4.9.0.0 +instance Show1 Proxy where + liftShowsPrec _ _ _ _ = showString "Proxy" + +-- | @since 4.9.0.0 +instance Read1 Proxy where + liftReadsPrec _ _ d = + readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) + +-- Building blocks + +-- | @'readsData' p d@ is a parser for datatypes where each alternative +-- begins with a data constructor. It parses the constructor and +-- passes it to @p@. Parsers for various constructors can be constructed +-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with +-- @mappend@ from the @Monoid@ class. +readsData :: (String -> ReadS a) -> Int -> ReadS a +readsData reader d = + readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] + +-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor +-- and then parses its argument using @rp@. +readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t +readsUnaryWith rp name cons kw s = + [(cons x,t) | kw == name, (x,t) <- rp 11 s] + +-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary +-- data constructor and then parses its arguments using @rp1@ and @rp2@ +-- respectively. +readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> + String -> (a -> b -> t) -> String -> ReadS t +readsBinaryWith rp1 rp2 name cons kw s = + [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] + +-- | @'showsUnaryWith' sp n d x@ produces the string representation of a +-- unary data constructor with name @n@ and argument @x@, in precedence +-- context @d@. +showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS +showsUnaryWith sp name d x = showParen (d > 10) $ + showString name . showChar ' ' . sp 11 x + +-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string +-- representation of a binary data constructor with name @n@ and arguments +-- @x@ and @y@, in precedence context @d@. +showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> + String -> Int -> a -> b -> ShowS +showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y + +-- Obsolete building blocks + +-- | @'readsUnary' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec'. +{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} +readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t +readsUnary name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] + +-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec1'. +{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} +readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t +readsUnary1 name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] + +-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor +-- and then parses its arguments using 'readsPrec1'. +{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} +readsBinary1 :: (Read1 f, Read1 g, Read a) => + String -> (f a -> g a -> t) -> String -> ReadS t +readsBinary1 name cons kw s = + [(cons x y,u) | kw == name, + (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] + +-- | @'showsUnary' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} +showsUnary :: (Show a) => String -> Int -> a -> ShowS +showsUnary name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec 11 x + +-- | @'showsUnary1' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} +showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS +showsUnary1 name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x + +-- | @'showsBinary1' n d x y@ produces the string representation of a binary +-- data constructor with name @n@ and arguments @x@ and @y@, in precedence +-- context @d@. +{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} +showsBinary1 :: (Show1 f, Show1 g, Show a) => + String -> Int -> f a -> g a -> ShowS +showsBinary1 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x . + showChar ' ' . showsPrec1 11 y + +{- $example +These functions can be used to assemble 'Read' and 'Show' instances for +new algebraic types. For example, given the definition + +> data T f a = Zero a | One (f a) | Two a (f a) + +a standard 'Read1' instance may be defined as + +> instance (Read1 f) => Read1 (T f) where +> liftReadsPrec rp rl = readsData $ +> readsUnaryWith rp "Zero" Zero `mappend` +> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` +> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two + +and the corresponding 'Show1' instance as + +> instance (Show1 f) => Show1 (T f) where +> liftShowsPrec sp _ d (Zero x) = +> showsUnaryWith sp "Zero" d x +> liftShowsPrec sp sl d (One x) = +> showsUnaryWith (liftShowsPrec sp sl) "One" d x +> liftShowsPrec sp sl d (Two x y) = +> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y + +-} diff --git a/Data/Functor/Compose.hs b/Data/Functor/Compose.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Compose.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Compose +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Composition of functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Compose ( + Compose(..), + ) where + +import Data.Functor.Classes + +import Control.Applicative +import Data.Data (Data) +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) +import GHC.Generics (Generic, Generic1) + +infixr 9 `Compose` + +-- | Right-to-left composition of functors. +-- 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) + +-- Instances of lifted Prelude classes + +instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where + liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y + +instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where + liftCompare comp (Compose x) (Compose y) = + liftCompare (liftCompare comp) x y + +instance (Read1 f, Read1 g) => Read1 (Compose f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 f, Show1 g) => Show1 (Compose f g) where + liftShowsPrec sp sl d (Compose x) = + showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +-- Instances of Prelude classes + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where + (==) = eq1 + +instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where + compare = compare1 + +instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where + readsPrec = readsPrec1 + +instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where + showsPrec = showsPrec1 + +-- Functor instances + +instance (Functor f, Functor g) => Functor (Compose f g) where + fmap f (Compose x) = Compose (fmap (fmap f) x) + +instance (Foldable f, Foldable g) => Foldable (Compose f g) where + foldMap f (Compose t) = foldMap (foldMap f) t + +instance (Traversable f, Traversable g) => Traversable (Compose f g) where + traverse f (Compose t) = Compose <$> traverse (traverse f) t + +instance (Applicative f, Applicative g) => Applicative (Compose f g) where + pure x = Compose (pure (pure x)) + Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) + +instance (Alternative f, Applicative g) => Alternative (Compose f g) where + empty = Compose empty + Compose x <|> Compose y = Compose (x <|> y) diff --git a/Data/Functor/Const.hs b/Data/Functor/Const.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Const.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Const +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable + +-- The 'Const' functor. +-- +-- @since 4.9.0.0 + +module Data.Functor.Const (Const(..)) where + +import Data.Bits (Bits, FiniteBits) +import Data.Foldable (Foldable(foldMap)) +import Foreign.Storable (Storable) + +import GHC.Arr (Ix) +import GHC.Base +import GHC.Enum (Bounded, Enum) +import GHC.Float (Floating, RealFloat) +import GHC.Generics (Generic, Generic1) +import GHC.Num (Num) +import GHC.Real (Fractional, Integral, Real, RealFrac) +import GHC.Read (Read(readsPrec), readParen, lex) +import GHC.Show (Show(showsPrec), showParen, showString) + +-- | The 'Const' functor. +newtype Const a b = Const { getConst :: a } + deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional + , Generic, Generic1, Integral, Ix, Monoid, Num, Ord, Real + , RealFrac, RealFloat , Storable) + +-- | This instance would be equivalent to the derived instances of the +-- 'Const' newtype if the 'runConst' field were removed +instance Read a => Read (Const a b) where + readsPrec d = readParen (d > 10) + $ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s] + +-- | This instance would be equivalent to the derived instances of the +-- 'Const' newtype if the 'runConst' field were removed +instance Show a => Show (Const a b) where + showsPrec d (Const x) = showParen (d > 10) $ + showString "Const " . showsPrec 11 x + +instance Foldable (Const m) where + foldMap _ _ = mempty + +instance Functor (Const m) where + fmap _ (Const v) = Const v + +instance Monoid m => Applicative (Const m) where + pure _ = Const mempty + (<*>) = coerce (mappend :: m -> m -> m) +-- This is pretty much the same as +-- Const f <*> Const v = Const (f `mappend` v) +-- but guarantees that mappend for Const a b will have the same arity +-- as the one for a; it won't create a closure to raise the arity +-- to 2. diff --git a/Data/Functor/Identity.hs b/Data/Functor/Identity.hs --- a/Data/Functor/Identity.hs +++ b/Data/Functor/Identity.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- @@ -35,16 +36,23 @@ import Control.Monad.Fix import Control.Monad.Zip +import Data.Bits (Bits, FiniteBits) import Data.Coerce import Data.Data (Data) import Data.Foldable +import Data.Ix (Ix) +import Data.Semigroup (Semigroup) +import Data.String (IsString) +import Foreign.Storable (Storable) import GHC.Generics (Generic, Generic1) -- | Identity functor and monad. (a non-strict monad) -- -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a } - deriving (Eq, Ord, Data, Traversable, Generic, Generic1) + deriving ( Bits, Bounded, Data, Enum, Eq, FiniteBits, Floating, Fractional + , Generic, Generic1, Integral, IsString, Ix, Monoid, Num, Ord + , Real, RealFrac, RealFloat , Semigroup, Storable, Traversable) -- | This instance would be equivalent to the derived instances of the -- 'Identity' newtype if the 'runIdentity' field were removed @@ -87,7 +95,6 @@ (<*>) = coerce instance Monad Identity where - return = Identity m >>= k = k (runIdentity m) instance MonadFix Identity where diff --git a/Data/Functor/Product.hs b/Data/Functor/Product.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Product.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Product +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Products, lifted to functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Product ( + Product(..), + ) where + +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.Zip (MonadZip(mzipWith)) +import Data.Data (Data) +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +import GHC.Generics (Generic, Generic1) + +-- | Lifted product of functors. +data Product f g a = Pair (f a) (g a) + deriving (Data, Generic, Generic1) + +instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where + liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 + +instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where + liftCompare comp (Pair x1 y1) (Pair x2 y2) = + liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 + +instance (Read1 f, Read1 g) => Read1 (Product f g) where + liftReadsPrec rp rl = readsData $ + readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair + +instance (Show1 f, Show1 g) => Show1 (Product f g) where + liftShowsPrec sp sl d (Pair x y) = + showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) + where (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Product f g) where + fmap f (Pair x y) = Pair (fmap f x) (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Product f g) where + traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y + +instance (Applicative f, Applicative g) => Applicative (Product f g) where + pure x = Pair (pure x) (pure x) + Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) + +instance (Alternative f, Alternative g) => Alternative (Product f g) where + empty = Pair empty empty + Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2) + +instance (Monad f, Monad g) => Monad (Product f g) where + Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where + mzero = Pair mzero mzero + Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) + +instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where + mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where + mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) diff --git a/Data/Functor/Sum.hs b/Data/Functor/Sum.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Sum.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Sum +-- Copyright : (c) Ross Paterson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Sums, lifted to functors. +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Functor.Sum ( + Sum(..), + ) where + +import Data.Data (Data) +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +import GHC.Generics (Generic, Generic1) + +-- | Lifted sum of functors. +data Sum f g a = InL (f a) | InR (g a) + deriving (Data, Generic, Generic1) + +instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where + liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 + liftEq _ (InL _) (InR _) = False + liftEq _ (InR _) (InL _) = False + liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 + +instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where + liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 + liftCompare _ (InL _) (InR _) = LT + liftCompare _ (InR _) (InL _) = GT + liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 + +instance (Read1 f, Read1 g) => Read1 (Sum f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` + readsUnaryWith (liftReadsPrec rp rl) "InR" InR + +instance (Show1 f, Show1 g) => Show1 (Sum f g) where + liftShowsPrec sp sl d (InL x) = + showsUnaryWith (liftShowsPrec sp sl) "InL" d x + liftShowsPrec sp sl d (InR y) = + showsUnaryWith (liftShowsPrec sp sl) "InR" d y + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where + (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Sum f g) where + fmap f (InL x) = InL (fmap f x) + fmap f (InR y) = InR (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Sum f g) where + foldMap f (InL x) = foldMap f x + foldMap f (InR y) = foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Sum f g) where + traverse f (InL x) = InL <$> traverse f x + traverse f (InR y) = InR <$> traverse f y diff --git a/Data/IORef.hs b/Data/IORef.hs --- a/Data/IORef.hs +++ b/Data/IORef.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} ----------------------------------------------------------------------------- -- | @@ -27,10 +27,7 @@ atomicModifyIORef, atomicModifyIORef', atomicWriteIORef, - -#if !defined(__PARALLEL_HASKELL__) mkWeakIORef, -#endif -- ** Memory Model -- $memmodel @@ -41,17 +38,13 @@ import GHC.STRef import GHC.IORef hiding (atomicModifyIORef) import qualified GHC.IORef -#if !defined(__PARALLEL_HASKELL__) import GHC.Weak -#endif -#if !defined(__PARALLEL_HASKELL__) -- |Make a 'Weak' pointer to an 'IORef', using the second argument as a finalizer -- to run when 'IORef' is garbage-collected mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a)) -mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s -> - case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #) -#endif +mkWeakIORef r@(IORef (STRef r#)) (IO finalizer) = IO $ \s -> + case mkWeak# r# r finalizer s of (# s1, w #) -> (# s1, Weak w #) -- |Mutate the contents of an 'IORef'. -- diff --git a/Data/Kind.hs b/Data/Kind.hs new file mode 100644 --- /dev/null +++ b/Data/Kind.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Trustworthy, ExplicitNamespaces #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Kind +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : not portable +-- +-- Basic kinds +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Kind ( Type, Constraint, type (*), type (★) ) where + +import GHC.Types diff --git a/Data/List.hs b/Data/List.hs --- a/Data/List.hs +++ b/Data/List.hs @@ -219,8 +219,9 @@ import GHC.Base ( Bool(..), Eq((==)), otherwise ) --- | The 'isSubsequenceOf' function takes two lists and returns 'True' if the --- first list is a subsequence of the second list. +-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if all +-- the elements of the first list occur, in order, in the second. The +-- elements do not have to occur consecutively. -- -- @'isSubsequenceOf' x y@ is equivalent to @'elem' x ('subsequences' y)@. -- diff --git a/Data/List/NonEmpty.hs b/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/Data/List/NonEmpty.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Trustworthy #-} -- can't use Safe due to IsList instance +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.List.NonEmpty +-- Copyright : (C) 2011-2015 Edward Kmett, +-- (C) 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A 'NonEmpty' list is one which always has at least one element, but +-- is otherwise identical to the traditional list type in complexity +-- and in terms of API. You will almost certainly want to import this +-- module @qualified@. +-- +-- @since 4.9.0.0 +---------------------------------------------------------------------------- + +module Data.List.NonEmpty ( + -- * The type of non-empty streams + NonEmpty(..) + + -- * Non-empty stream transformations + , map -- :: (a -> b) -> NonEmpty a -> NonEmpty b + , intersperse -- :: a -> NonEmpty a -> NonEmpty a + , scanl -- :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b + , scanr -- :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b + , scanl1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , scanr1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , transpose -- :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) + , sortBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a + , sortWith -- :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a + -- * Basic functions + , length -- :: NonEmpty a -> Int + , head -- :: NonEmpty a -> a + , tail -- :: NonEmpty a -> [a] + , last -- :: NonEmpty a -> a + , init -- :: NonEmpty a -> [a] + , (<|), cons -- :: a -> NonEmpty a -> NonEmpty a + , uncons -- :: NonEmpty a -> (a, Maybe (NonEmpty a)) + , unfoldr -- :: (a -> (b, Maybe a)) -> a -> NonEmpty b + , sort -- :: NonEmpty a -> NonEmpty a + , reverse -- :: NonEmpty a -> NonEmpty a + , inits -- :: Foldable f => f a -> NonEmpty a + , tails -- :: Foldable f => f a -> NonEmpty a + -- * Building streams + , iterate -- :: (a -> a) -> a -> NonEmpty a + , repeat -- :: a -> NonEmpty a + , cycle -- :: NonEmpty a -> NonEmpty a + , unfold -- :: (a -> (b, Maybe a) -> a -> NonEmpty b + , insert -- :: (Foldable f, Ord a) => a -> f a -> NonEmpty a + , some1 -- :: Alternative f => f a -> f (NonEmpty a) + -- * Extracting sublists + , take -- :: Int -> NonEmpty a -> [a] + , drop -- :: Int -> NonEmpty a -> [a] + , splitAt -- :: Int -> NonEmpty a -> ([a], [a]) + , takeWhile -- :: Int -> NonEmpty a -> [a] + , dropWhile -- :: Int -> NonEmpty a -> [a] + , span -- :: Int -> NonEmpty a -> ([a],[a]) + , break -- :: Int -> NonEmpty a -> ([a],[a]) + , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) + , group -- :: Foldable f => Eq a => f a -> [NonEmpty a] + , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] + , groupWith -- :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a] + , groupAllWith -- :: (Foldable f, Ord b) => (a -> b) -> f a -> [NonEmpty a] + , group1 -- :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) + , groupBy1 -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) + , groupWith1 -- :: (Foldable f, Eq b) => (a -> b) -> f a -> NonEmpty (NonEmpty a) + , groupAllWith1 -- :: (Foldable f, Ord b) => (a -> b) -> f a -> NonEmpty (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: Foldable f => f a -> NonEmpty a -> Bool + -- * \"Set\" operations + , nub -- :: Eq a => NonEmpty a -> NonEmpty a + , nubBy -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a + -- * Indexing streams + , (!!) -- :: NonEmpty a -> Int -> a + -- * Zipping and unzipping streams + , zip -- :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) + , zipWith -- :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c + , unzip -- :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) + -- * Converting to and from a list + , fromList -- :: [a] -> NonEmpty a + , toList -- :: NonEmpty a -> [a] + , nonEmpty -- :: [a] -> Maybe (NonEmpty a) + , xor -- :: NonEmpty a -> Bool + ) where + + +import Prelude hiding (break, cycle, drop, dropWhile, + filter, foldl, foldr, head, init, iterate, + last, length, map, repeat, reverse, + scanl, scanl1, scanr, scanr1, span, + splitAt, tail, take, takeWhile, + unzip, zip, zipWith, (!!)) +import qualified Prelude + +import Control.Applicative (Alternative, many) +import Control.Monad (ap) +import Control.Monad.Fix +import Control.Monad.Zip (MonadZip(..)) +import Data.Data (Data) +import Data.Foldable hiding (length, toList) +import qualified Data.Foldable as Foldable +import Data.Function (on) +import qualified Data.List as List +import Data.Ord (comparing) +import qualified GHC.Exts as Exts (IsList(..)) +import GHC.Generics (Generic, Generic1) + +infixr 5 :|, <| + +-- | Non-empty (and non-strict) list type. +-- +-- @since 4.9.0.0 +data NonEmpty a = a :| [a] + deriving ( Eq, Ord, Show, Read, Data, Generic, Generic1 ) + +instance Exts.IsList (NonEmpty a) where + type Item (NonEmpty a) = a + fromList = fromList + toList = toList + +instance MonadFix NonEmpty where + mfix f = case fix (f . head) of + ~(x :| _) -> x :| mfix (tail . f) + +instance MonadZip NonEmpty where + mzip = zip + mzipWith = zipWith + munzip = unzip + +-- | Number of elements in 'NonEmpty' list. +length :: NonEmpty a -> Int +length (_ :| xs) = 1 + Prelude.length xs + +-- | Compute n-ary logic exclusive OR operation on 'NonEmpty' list. +xor :: NonEmpty Bool -> Bool +xor (x :| xs) = foldr xor' x xs + where xor' True y = not y + xor' False y = y + +-- | 'unfold' produces a new stream by repeatedly applying the unfolding +-- function to the seed value to produce an element of type @b@ and a new +-- seed value. When the unfolding function returns 'Nothing' instead of +-- a new seed value, the stream ends. +unfold :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfold f a = case f a of + (b, Nothing) -> b :| [] + (b, Just c) -> b <| unfold f c + +-- | 'nonEmpty' efficiently turns a normal list into a 'NonEmpty' stream, +-- producing 'Nothing' if the input is empty. +nonEmpty :: [a] -> Maybe (NonEmpty a) +nonEmpty [] = Nothing +nonEmpty (a:as) = Just (a :| as) + +-- | 'uncons' produces the first element of the stream, and a stream of the +-- remaining elements, if any. +uncons :: NonEmpty a -> (a, Maybe (NonEmpty a)) +uncons ~(a :| as) = (a, nonEmpty as) + +-- | The 'unfoldr' function is analogous to "Data.List"'s +-- 'Data.List.unfoldr' operation. +unfoldr :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfoldr f a = case f a of + (b, mc) -> b :| maybe [] go mc + where + go c = case f c of + (d, me) -> d : maybe [] go me + +instance Functor NonEmpty where + fmap f ~(a :| as) = f a :| fmap f as + b <$ ~(_ :| as) = b :| (b <$ as) + +instance Applicative NonEmpty where + pure a = a :| [] + (<*>) = ap + +instance Monad NonEmpty where + ~(a :| as) >>= f = b :| (bs ++ bs') + where b :| bs = f a + bs' = as >>= toList . f + +instance Traversable NonEmpty where + traverse f ~(a :| as) = (:|) <$> f a <*> traverse f as + +instance Foldable NonEmpty where + foldr f z ~(a :| as) = f a (foldr f z as) + foldl f z ~(a :| as) = foldl f (f z a) as + foldl1 f ~(a :| as) = foldl f a as + foldMap f ~(a :| as) = f a `mappend` foldMap f as + fold ~(m :| ms) = m `mappend` fold ms + +-- | Extract the first element of the stream. +head :: NonEmpty a -> a +head ~(a :| _) = a + +-- | Extract the possibly-empty tail of the stream. +tail :: NonEmpty a -> [a] +tail ~(_ :| as) = as + +-- | Extract the last element of the stream. +last :: NonEmpty a -> a +last ~(a :| as) = List.last (a : as) + +-- | Extract everything except the last element of the stream. +init :: NonEmpty a -> [a] +init ~(a :| as) = List.init (a : as) + +-- | Prepend an element to the stream. +(<|) :: a -> NonEmpty a -> NonEmpty a +a <| ~(b :| bs) = a :| b : bs + +-- | Synonym for '<|'. +cons :: a -> NonEmpty a -> NonEmpty a +cons = (<|) + +-- | Sort a stream. +sort :: Ord a => NonEmpty a -> NonEmpty a +sort = lift List.sort + +-- | Converts a normal list to a 'NonEmpty' stream. +-- +-- Raises an error if given an empty list. +fromList :: [a] -> NonEmpty a +fromList (a:as) = a :| as +fromList [] = errorWithoutStackTrace "NonEmpty.fromList: empty list" + +-- | Convert a stream to a normal list efficiently. +toList :: NonEmpty a -> [a] +toList ~(a :| as) = a : as + +-- | Lift list operations to work on a 'NonEmpty' stream. +-- +-- /Beware/: If the provided function returns an empty list, +-- this will raise an error. +lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b +lift f = fromList . f . Foldable.toList + +-- | Map a function over a 'NonEmpty' stream. +map :: (a -> b) -> NonEmpty a -> NonEmpty b +map f ~(a :| as) = f a :| fmap f as + +-- | The 'inits' function takes a stream @xs@ and returns all the +-- finite prefixes of @xs@. +inits :: Foldable f => f a -> NonEmpty [a] +inits = fromList . List.inits . Foldable.toList + +-- | The 'tails' function takes a stream @xs@ and returns all the +-- suffixes of @xs@. +tails :: Foldable f => f a -> NonEmpty [a] +tails = fromList . List.tails . Foldable.toList + +-- | @'insert' x xs@ inserts @x@ into the last position in @xs@ where it +-- is still less than or equal to the next element. In particular, if the +-- list is sorted beforehand, the result will also be sorted. +insert :: (Foldable f, Ord a) => a -> f a -> NonEmpty a +insert a = fromList . List.insert a . Foldable.toList + +-- | @'some1' x@ sequences @x@ one or more times. +some1 :: Alternative f => f a -> f (NonEmpty a) +some1 x = (:|) <$> x <*> many x + +-- | 'scanl' is similar to 'foldl', but returns a stream of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == z :| [z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b +scanl f z = fromList . List.scanl f z . Foldable.toList + +-- | 'scanr' is the right-to-left dual of 'scanl'. +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs. +scanr :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b +scanr f z = fromList . List.scanr f z . Foldable.toList + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == x1 :| [x1 `f` x2, x1 `f` (x2 `f` x3), ...] +scanl1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a +scanl1 f ~(a :| as) = fromList (List.scanl f a as) + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a +scanr1 f ~(a :| as) = fromList (List.scanr1 f (a:as)) + +-- | 'intersperse x xs' alternates elements of the list with copies of @x@. +-- +-- > intersperse 0 (1 :| [2,3]) == 1 :| [0,2,0,3] +intersperse :: a -> NonEmpty a -> NonEmpty a +intersperse a ~(b :| bs) = b :| case bs of + [] -> [] + _ -> a : List.intersperse a bs + +-- | @'iterate' f x@ produces the infinite sequence +-- of repeated applications of @f@ to @x@. +-- +-- > iterate f x = x :| [f x, f (f x), ..] +iterate :: (a -> a) -> a -> NonEmpty a +iterate f a = a :| List.iterate f (f a) + +-- | @'cycle' xs@ returns the infinite repetition of @xs@: +-- +-- > cycle (1 :| [2,3]) = 1 :| [2,3,1,2,3,...] +cycle :: NonEmpty a -> NonEmpty a +cycle = fromList . List.cycle . toList + +-- | 'reverse' a finite NonEmpty stream. +reverse :: NonEmpty a -> NonEmpty a +reverse = lift List.reverse + +-- | @'repeat' x@ returns a constant stream, where all elements are +-- equal to @x@. +repeat :: a -> NonEmpty a +repeat a = a :| List.repeat a + +-- | @'take' n xs@ returns the first @n@ elements of @xs@. +take :: Int -> NonEmpty a -> [a] +take n = List.take n . toList + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +drop :: Int -> NonEmpty a -> [a] +drop n = List.drop n . toList + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of @xs@ +-- of length @n@ and the remaining stream immediately following this prefix. +-- +-- > 'splitAt' n xs == ('take' n xs, 'drop' n xs) +-- > xs == ys ++ zs where (ys, zs) = 'splitAt' n xs +splitAt :: Int -> NonEmpty a -> ([a],[a]) +splitAt n = List.splitAt n . toList + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> NonEmpty a -> [a] +takeWhile p = List.takeWhile p . toList + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +dropWhile :: (a -> Bool) -> NonEmpty a -> [a] +dropWhile p = List.dropWhile p . toList + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +-- +-- > 'span' p xs == ('takeWhile' p xs, 'dropWhile' p xs) +-- > xs == ys ++ zs where (ys, zs) = 'span' p xs +span :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +span p = List.span p . toList + +-- | The @'break' p@ function is equivalent to @'span' (not . p)@. +break :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +break p = span (not . p) + +-- | @'filter' p xs@ removes any elements from @xs@ that do not satisfy @p@. +filter :: (a -> Bool) -> NonEmpty a -> [a] +filter p = List.filter p . toList + +-- | The 'partition' function takes a predicate @p@ and a stream +-- @xs@, and returns a pair of lists. The first list corresponds to the +-- elements of @xs@ for which @p@ holds; the second corresponds to the +-- elements of @xs@ for which @p@ does not hold. +-- +-- > 'partition' p xs = ('filter' p xs, 'filter' (not . p) xs) +partition :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +partition p = List.partition p . toList + +-- | The 'group' function takes a stream and returns a list of +-- streams such that flattening the resulting list is equal to the +-- argument. Moreover, each stream in the resulting list +-- contains only equal elements. For example, in list notation: +-- +-- > 'group' $ 'cycle' "Mississippi" +-- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +group :: (Foldable f, Eq a) => f a -> [NonEmpty a] +group = groupBy (==) + +-- | 'groupBy' operates like 'group', but uses the provided equality +-- predicate instead of `==`. +groupBy :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] +groupBy eq0 = go eq0 . Foldable.toList + where + go _ [] = [] + go eq (x : xs) = (x :| ys) : groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +-- | 'groupWith' operates like 'group', but uses the provided projection when +-- comparing for equality +groupWith :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a] +groupWith f = groupBy ((==) `on` f) + +-- | 'groupAllWith' operates like 'groupWith', but sorts the list +-- first so that each equivalence class has, at most, one list in the +-- output +groupAllWith :: (Ord b) => (a -> b) -> [a] -> [NonEmpty a] +groupAllWith f = groupWith f . List.sortBy (compare `on` f) + +-- | 'group1' operates like 'group', but uses the knowledge that its +-- input is non-empty to produce guaranteed non-empty output. +group1 :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) +group1 = groupBy1 (==) + +-- | 'groupBy1' is to 'group1' as 'groupBy' is to 'group'. +groupBy1 :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupBy1 eq (x :| xs) = (x :| ys) :| groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +-- | 'groupWith1' is to 'group1' as 'groupWith' is to 'group' +groupWith1 :: (Eq b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupWith1 f = groupBy1 ((==) `on` f) + +-- | 'groupAllWith1' is to 'groupWith1' as 'groupAllWith' is to 'groupWith' +groupAllWith1 :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupAllWith1 f = groupWith1 f . sortWith f + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool +isPrefixOf [] _ = True +isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: a negative or out-of-bounds index will cause an error. +(!!) :: NonEmpty a -> Int -> a +(!!) ~(x :| xs) n + | n == 0 = x + | n > 0 = xs List.!! (n - 1) + | otherwise = errorWithoutStackTrace "NonEmpty.!! negative argument" + +-- | The 'zip' function takes two streams and returns a stream of +-- corresponding pairs. +zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) +zip ~(x :| xs) ~(y :| ys) = (x, y) :| List.zip xs ys + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the elements, the elements are combined using the function +-- passed as the first argument. +zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c +zipWith f ~(x :| xs) ~(y :| ys) = f x y :| List.zipWith f xs ys + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Functor f => f (a,b) -> (f a, f b) +unzip xs = (fst <$> xs, snd <$> xs) + +-- | The 'nub' function removes duplicate elements from a list. In +-- particular, it keeps only the first occurence of each element. +-- (The name 'nub' means \'essence\'.) +-- It is a special case of 'nubBy', which allows the programmer to +-- supply their own inequality test. +nub :: Eq a => NonEmpty a -> NonEmpty a +nub = nubBy (==) + +-- | The 'nubBy' function behaves just like 'nub', except it uses a +-- user-supplied equality predicate instead of the overloaded '==' +-- function. +nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a +nubBy eq (a :| as) = a :| List.nubBy eq (List.filter (\b -> not (eq a b)) as) + +-- | 'transpose' for 'NonEmpty', behaves the same as 'Data.List.transpose' +-- The rows/columns need not be the same length, in which case +-- > transpose . transpose /= id +transpose :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) +transpose = fmap fromList + . fromList . List.transpose . Foldable.toList + . fmap Foldable.toList + +-- | 'sortBy' for 'NonEmpty', behaves the same as 'Data.List.sortBy' +sortBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a +sortBy f = lift (List.sortBy f) + +-- | 'sortWith' for 'NonEmpty', behaves the same as: +-- +-- > sortBy . comparing +sortWith :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a +sortWith = sortBy . comparing diff --git a/Data/Maybe.hs b/Data/Maybe.hs --- a/Data/Maybe.hs +++ b/Data/Maybe.hs @@ -144,7 +144,7 @@ -- *** Exception: Maybe.fromJust: Nothing -- fromJust :: Maybe a -> a -fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck +fromJust Nothing = errorWithoutStackTrace "Maybe.fromJust: Nothing" -- yuck fromJust (Just x) = x -- | The 'fromMaybe' function takes a default value and and 'Maybe' diff --git a/Data/Monoid.hs b/Data/Monoid.hs --- a/Data/Monoid.hs +++ b/Data/Monoid.hs @@ -1,6 +1,5 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} @@ -75,6 +74,16 @@ mempty = Dual mempty Dual x `mappend` Dual y = Dual (y `mappend` x) +instance Functor Dual where + fmap = coerce + +instance Applicative Dual where + pure = Dual + (<*>) = coerce + +instance Monad Dual where + m >>= k = k (getDual m) + -- | The monoid of endomorphisms under composition. newtype Endo a = Endo { appEndo :: a -> a } deriving (Generic) @@ -108,6 +117,16 @@ mappend = coerce ((+) :: a -> a -> a) -- Sum x `mappend` Sum y = Sum (x + y) +instance Functor Sum where + fmap = coerce + +instance Applicative Sum where + pure = Sum + (<*>) = coerce + +instance Monad Sum where + m >>= k = k (getSum m) + -- | Monoid under multiplication. newtype Product a = Product { getProduct :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) @@ -117,6 +136,16 @@ mappend = coerce ((*) :: a -> a -> a) -- Product x `mappend` Product y = Product (x * y) +instance Functor Product where + fmap = coerce + +instance Applicative Product where + pure = Product + (<*>) = coerce + +instance Monad Product where + m >>= k = k (getProduct m) + -- $MaybeExamples -- To implement @find@ or @findLast@ on any 'Foldable': -- @@ -182,7 +211,7 @@ deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum, Monad, MonadPlus, Applicative, Alternative, Functor) -instance forall f a . Alternative f => Monoid (Alt f a) where +instance Alternative f => Monoid (Alt f a) where mempty = Alt empty mappend = coerce ((<|>) :: f a -> f a -> f a) @@ -206,4 +235,3 @@ where listLastToMaybe [] = Nothing listLastToMaybe lst = Just (last lst) -- -} - diff --git a/Data/OldList.hs b/Data/OldList.hs --- a/Data/OldList.hs +++ b/Data/OldList.hs @@ -563,7 +563,7 @@ -- and returns the greatest element of the list by the comparison function. -- The list must be finite and non-empty. maximumBy :: (a -> a -> Ordering) -> [a] -> a -maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy _ [] = errorWithoutStackTrace "List.maximumBy: empty list" maximumBy cmp xs = foldl1 maxBy xs where maxBy x y = case cmp x y of @@ -574,7 +574,7 @@ -- and returns the least element of the list by the comparison function. -- The list must be finite and non-empty. minimumBy :: (a -> a -> Ordering) -> [a] -> a -minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy _ [] = errorWithoutStackTrace "List.minimumBy: empty list" minimumBy cmp xs = foldl1 minBy xs where minBy x y = case cmp x y of @@ -629,8 +629,8 @@ genericIndex (x:_) 0 = x genericIndex (_:xs) n | n > 0 = genericIndex xs (n-1) - | otherwise = error "List.genericIndex: negative argument." -genericIndex _ _ = error "List.genericIndex: index too large." + | otherwise = errorWithoutStackTrace "List.genericIndex: negative argument." +genericIndex _ _ = errorWithoutStackTrace "List.genericIndex: index too large." -- | The 'genericReplicate' function is an overloaded version of 'replicate', -- which accepts any 'Integral' value as the number of repetitions to make. @@ -973,7 +973,7 @@ #endif /* USE_REPORT_PRELUDE */ -- | Sort a list by comparing the results of a key function applied to each --- element. @sortOn f@ is equivalent to @sortBy . comparing f@, but has the +-- element. @sortOn f@ is equivalent to @sortBy (comparing f)@, but has the -- performance advantage of only evaluating @f@ once for each element in the -- input list. This is called the decorate-sort-undecorate paradigm, or -- Schwartzian transform. @@ -1044,6 +1044,20 @@ -- | 'lines' breaks a string up into a list of strings at newline -- characters. The resulting strings do not contain newlines. +-- +-- Note that after splitting the string at newline characters, the +-- last part of the string is considered a line even if it doesn't end +-- with a newline. For example, +-- +-- > lines "" == [] +-- > lines "\n" == [""] +-- > lines "one" == ["one"] +-- > lines "one\n" == ["one"] +-- > lines "one\n\n" == ["one",""] +-- > lines "one\ntwo" == ["one","two"] +-- > lines "one\ntwo\n" == ["one","two"] +-- +-- Thus @'lines' s@ contains at least as many elements as newlines in @s@. lines :: String -> [String] lines "" = [] -- Somehow GHC doesn't detect the selector thunks in the below code, diff --git a/Data/Proxy.hs b/Data/Proxy.hs --- a/Data/Proxy.hs +++ b/Data/Proxy.hs @@ -52,11 +52,11 @@ readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) instance Enum (Proxy s) where - succ _ = error "Proxy.succ" - pred _ = error "Proxy.pred" + succ _ = errorWithoutStackTrace "Proxy.succ" + pred _ = errorWithoutStackTrace "Proxy.pred" fromEnum _ = 0 toEnum 0 = Proxy - toEnum _ = error "Proxy.toEnum: 0 expected" + toEnum _ = errorWithoutStackTrace "Proxy.toEnum: 0 expected" enumFrom _ = [Proxy] enumFromThen _ _ = [Proxy] enumFromThenTo _ _ _ = [Proxy] @@ -89,11 +89,17 @@ _ <*> _ = Proxy {-# INLINE (<*>) #-} +instance Alternative Proxy where + empty = Proxy + {-# INLINE empty #-} + _ <|> _ = Proxy + {-# INLINE (<|>) #-} + instance Monad Proxy where - return _ = Proxy - {-# INLINE return #-} _ >>= _ = Proxy {-# INLINE (>>=) #-} + +instance MonadPlus Proxy -- | 'asProxyTypeOf' is a type-restricted version of 'const'. -- It is usually used as an infix operator, and its typing forces its first diff --git a/Data/Semigroup.hs b/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/Data/Semigroup.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semigroup +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- In mathematics, a semigroup is an algebraic structure consisting of a +-- set together with an associative binary operation. A semigroup +-- generalizes a monoid in that there might not exist an identity +-- element. It also (originally) generalized a group (a monoid with all +-- inverses) to a type where every element did not have to have an inverse, +-- thus the name semigroup. +-- +-- The use of @(\<\>)@ in this module conflicts with an operator with the same +-- name that is being exported by Data.Monoid. However, this package +-- re-exports (most of) the contents of Data.Monoid, so to use semigroups +-- and monoids in the same package just +-- +-- > import Data.Semigroup +-- +-- @since 4.9.0.0 +---------------------------------------------------------------------------- +module Data.Semigroup ( + Semigroup(..) + , stimesMonoid + , stimesIdempotent + , stimesIdempotentMonoid + , mtimesDefault + -- * Semigroups + , Min(..) + , Max(..) + , First(..) + , Last(..) + , WrappedMonoid(..) + -- * Re-exported monoids from Data.Monoid + , Monoid(..) + , Dual(..) + , Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + -- * A better monoid for Maybe + , Option(..) + , option + -- * Difference lists of a semigroup + , diff + , cycle1 + -- * ArgMin, ArgMax + , Arg(..) + , ArgMin + , ArgMax + ) where + +import Prelude hiding (foldr1) + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Bifunctor +import Data.Coerce +import Data.Data +import Data.List.NonEmpty +import Data.Monoid (All (..), Any (..), Dual (..), Endo (..), + Product (..), Sum (..)) +import Data.Monoid (Alt (..)) +import qualified Data.Monoid as Monoid +import Data.Void +import GHC.Generics + +infixr 6 <> + +-- | The class of semigroups (types with an associative binary operation). +-- +-- @since 4.9.0.0 +class Semigroup a where + -- | An associative operation. + -- + -- @ + -- (a '<>' b) '<>' c = a '<>' (b '<>' c) + -- @ + -- + -- If @a@ is also a 'Monoid' we further require + -- + -- @ + -- ('<>') = 'mappend' + -- @ + (<>) :: a -> a -> a + + default (<>) :: Monoid a => a -> a -> a + (<>) = mappend + + -- | Reduce a non-empty list with @\<\>@ + -- + -- The default definition should be sufficient, but this can be + -- overridden for efficiency. + -- + sconcat :: NonEmpty a -> a + sconcat (a :| as) = go a as where + go b (c:cs) = b <> go c cs + go b [] = b + + -- | Repeat a value @n@ times. + -- + -- Given that this works on a 'Semigroup' it is allowed to fail if + -- you request 0 or fewer repetitions, and the default definition + -- will do so. + -- + -- By making this a member of the class, idempotent semigroups and monoids can + -- upgrade this to execute in /O(1)/ by picking + -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ + -- respectively. + stimes :: Integral b => b -> a -> a + stimes y0 x0 + | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | even y = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) (pred y `quot` 2) x + g x y z + | even y = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) + +-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. +-- May fail to terminate for some values in some semigroups. +cycle1 :: Semigroup m => m -> m +cycle1 xs = xs' where xs' = xs <> xs' + +instance Semigroup () where + _ <> _ = () + sconcat _ = () + stimes _ _ = () + +instance Semigroup b => Semigroup (a -> b) where + f <> g = \a -> f a <> g a + stimes n f e = stimes n (f e) + +instance Semigroup [a] where + (<>) = (++) + stimes n x + | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" + | otherwise = rep n + where + rep 0 = [] + rep i = x ++ rep (i - 1) + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + stimes _ Nothing = Nothing + stimes n (Just a) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" + EQ -> Nothing + GT -> Just (stimes n a) + +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a + stimes = stimesIdempotent + +instance (Semigroup a, Semigroup b) => Semigroup (a, b) where + (a,b) <> (a',b') = (a<>a',b<>b') + stimes n (a,b) = (stimes n a, stimes n b) + +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where + (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') + stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (a, b, c, d) where + (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') + stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) + => Semigroup (a, b, c, d, e) where + (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') + stimes n (a,b,c,d,e) = + (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) + +instance Semigroup Ordering where + LT <> _ = LT + EQ <> y = y + GT <> _ = GT + stimes = stimesIdempotentMonoid + +instance Semigroup a => Semigroup (Dual a) where + Dual a <> Dual b = Dual (b <> a) + stimes n (Dual a) = Dual (stimes n a) + +instance Semigroup (Endo a) where + (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) + stimes = stimesMonoid + +instance Semigroup All where + (<>) = coerce (&&) + stimes = stimesIdempotentMonoid + +instance Semigroup Any where + (<>) = coerce (||) + stimes = stimesIdempotentMonoid + + +instance Num a => Semigroup (Sum a) where + (<>) = coerce ((+) :: a -> a -> a) + stimes n (Sum a) = Sum (fromIntegral n * a) + +instance Num a => Semigroup (Product a) where + (<>) = coerce ((*) :: a -> a -> a) + stimes n (Product a) = Product (a ^ n) + +-- | This is a valid definition of 'stimes' for a 'Monoid'. +-- +-- Unlike the default definition of 'stimes', it is defined for 0 +-- and so it should be preferred where possible. +stimesMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesMonoid n x0 = case compare n 0 of + LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" + EQ -> mempty + GT -> f x0 n + where + f x y + | even y = f (x `mappend` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `mappend` x) (pred y `quot` 2) x + g x y z + | even y = g (x `mappend` x) (y `quot` 2) z + | y == 1 = x `mappend` z + | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) + +-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. +-- +-- When @mappend x x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/ +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesIdempotentMonoid n x = case compare n 0 of + LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x + +-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. +-- +-- When @x <> x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/. +stimesIdempotent :: Integral b => b -> a -> a +stimesIdempotent n x + | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" + | otherwise = x + +instance Semigroup a => Semigroup (Const a b) where + (<>) = coerce ((<>) :: a -> a -> a) + stimes n (Const a) = Const (stimes n a) + +instance Semigroup (Monoid.First a) where + Monoid.First Nothing <> b = b + a <> _ = a + stimes = stimesIdempotentMonoid + +instance Semigroup (Monoid.Last a) where + a <> Monoid.Last Nothing = a + _ <> b = b + stimes = stimesIdempotentMonoid + +instance Alternative f => Semigroup (Alt f a) where + (<>) = coerce ((<|>) :: f a -> f a -> f a) + stimes = stimesMonoid + +instance Semigroup Void where + a <> _ = a + stimes = stimesIdempotent + +instance Semigroup (NonEmpty a) where + (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) + + +newtype Min a = Min { getMin :: a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Min a) where + minBound = Min minBound + maxBound = Min maxBound + +instance Enum a => Enum (Min a) where + succ (Min a) = Min (succ a) + pred (Min a) = Min (pred a) + toEnum = Min . toEnum + fromEnum = fromEnum . getMin + enumFrom (Min a) = Min <$> enumFrom a + enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b + enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b + enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c + + +instance Ord a => Semigroup (Min a) where + (<>) = coerce (min :: a -> a -> a) + stimes = stimesIdempotent + +instance (Ord a, Bounded a) => Monoid (Min a) where + mempty = maxBound + mappend = (<>) + +instance Functor Min where + fmap f (Min x) = Min (f x) + +instance Foldable Min where + foldMap f (Min a) = f a + +instance Traversable Min where + traverse f (Min a) = Min <$> f a + +instance Applicative Min where + pure = Min + a <* _ = a + _ *> a = a + Min f <*> Min x = Min (f x) + +instance Monad Min where + (>>) = (*>) + Min a >>= f = f a + +instance MonadFix Min where + mfix f = fix (f . getMin) + +instance Num a => Num (Min a) where + (Min a) + (Min b) = Min (a + b) + (Min a) * (Min b) = Min (a * b) + (Min a) - (Min b) = Min (a - b) + negate (Min a) = Min (negate a) + abs (Min a) = Min (abs a) + signum (Min a) = Min (signum a) + fromInteger = Min . fromInteger + +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Max a) where + minBound = Max minBound + maxBound = Max maxBound + +instance Enum a => Enum (Max a) where + succ (Max a) = Max (succ a) + pred (Max a) = Max (pred a) + toEnum = Max . toEnum + fromEnum = fromEnum . getMax + enumFrom (Max a) = Max <$> enumFrom a + enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b + enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b + enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c + +instance Ord a => Semigroup (Max a) where + (<>) = coerce (max :: a -> a -> a) + stimes = stimesIdempotent + +instance (Ord a, Bounded a) => Monoid (Max a) where + mempty = minBound + mappend = (<>) + +instance Functor Max where + fmap f (Max x) = Max (f x) + +instance Foldable Max where + foldMap f (Max a) = f a + +instance Traversable Max where + traverse f (Max a) = Max <$> f a + +instance Applicative Max where + pure = Max + a <* _ = a + _ *> a = a + Max f <*> Max x = Max (f x) + +instance Monad Max where + (>>) = (*>) + Max a >>= f = f a + +instance MonadFix Max where + mfix f = fix (f . getMax) + +instance Num a => Num (Max a) where + (Max a) + (Max b) = Max (a + b) + (Max a) * (Max b) = Max (a * b) + (Max a) - (Max b) = Max (a - b) + negate (Max a) = Max (negate a) + abs (Max a) = Max (abs a) + signum (Max a) = Max (signum a) + fromInteger = Max . fromInteger + +-- | '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, Typeable, Generic, Generic1) + +type ArgMin a b = Min (Arg a b) +type ArgMax a b = Max (Arg a b) + +instance Functor (Arg a) where + fmap f (Arg x a) = Arg x (f a) + +instance Foldable (Arg a) where + foldMap f (Arg _ a) = f a + +instance Traversable (Arg a) where + traverse f (Arg x a) = Arg x <$> f a + +instance Eq a => Eq (Arg a b) where + Arg a _ == Arg b _ = a == b + +instance Ord a => Ord (Arg a b) where + Arg a _ `compare` Arg b _ = compare a b + min x@(Arg a _) y@(Arg b _) + | a <= b = x + | otherwise = y + max x@(Arg a _) y@(Arg b _) + | a >= b = x + | otherwise = y + +instance Bifunctor Arg where + bimap f g (Arg a b) = Arg (f a) (g b) + +-- | Use @'Option' ('First' a)@ to get the behavior of +-- 'Data.Monoid.First' from "Data.Monoid". +newtype First a = First { getFirst :: a } deriving + (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (First a) where + minBound = First minBound + maxBound = First maxBound + +instance Enum a => Enum (First a) where + succ (First a) = First (succ a) + pred (First a) = First (pred a) + toEnum = First . toEnum + fromEnum = fromEnum . getFirst + enumFrom (First a) = First <$> enumFrom a + enumFromThen (First a) (First b) = First <$> enumFromThen a b + enumFromTo (First a) (First b) = First <$> enumFromTo a b + enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c + +instance Semigroup (First a) where + a <> _ = a + stimes = stimesIdempotent + +instance Functor First where + fmap f (First x) = First (f x) + +instance Foldable First where + foldMap f (First a) = f a + +instance Traversable First where + traverse f (First a) = First <$> f a + +instance Applicative First where + pure x = First x + a <* _ = a + _ *> a = a + First f <*> First x = First (f x) + +instance Monad First where + (>>) = (*>) + First a >>= f = f a + +instance MonadFix First where + mfix f = fix (f . getFirst) + +-- | Use @'Option' ('Last' a)@ to get the behavior of +-- 'Data.Monoid.Last' from "Data.Monoid" +newtype Last a = Last { getLast :: a } deriving + (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Last a) where + minBound = Last minBound + maxBound = Last maxBound + +instance Enum a => Enum (Last a) where + succ (Last a) = Last (succ a) + pred (Last a) = Last (pred a) + toEnum = Last . toEnum + fromEnum = fromEnum . getLast + enumFrom (Last a) = Last <$> enumFrom a + enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b + enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b + enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c + +instance Semigroup (Last a) where + _ <> b = b + stimes = stimesIdempotent + +instance Functor Last where + fmap f (Last x) = Last (f x) + a <$ _ = Last a + +instance Foldable Last where + foldMap f (Last a) = f a + +instance Traversable Last where + traverse f (Last a) = Last <$> f a + +instance Applicative Last where + pure = Last + a <* _ = a + _ *> a = a + Last f <*> Last x = Last (f x) + +instance Monad Last where + (>>) = (*>) + Last a >>= f = f a + +instance MonadFix Last where + mfix f = fix (f . getLast) + +-- | Provide a Semigroup for an arbitrary Monoid. +newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Monoid m => Semigroup (WrappedMonoid m) where + (<>) = coerce (mappend :: m -> m -> m) + +instance Monoid m => Monoid (WrappedMonoid m) where + mempty = WrapMonoid mempty + mappend = (<>) + +instance Bounded a => Bounded (WrappedMonoid a) where + minBound = WrapMonoid minBound + maxBound = WrapMonoid maxBound + +instance Enum a => Enum (WrappedMonoid a) where + succ (WrapMonoid a) = WrapMonoid (succ a) + pred (WrapMonoid a) = WrapMonoid (pred a) + toEnum = WrapMonoid . toEnum + fromEnum = fromEnum . unwrapMonoid + enumFrom (WrapMonoid a) = WrapMonoid <$> enumFrom a + enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b + enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b + enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) = + WrapMonoid <$> enumFromThenTo a b c + +-- | Repeat a value @n@ times. +-- +-- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times +-- +-- Implemented using 'stimes' and 'mempty'. +-- +-- This is a suitable definition for an 'mtimes' member of 'Monoid'. +mtimesDefault :: (Integral b, Monoid a) => b -> a -> a +mtimesDefault n x + | n == 0 = mempty + | otherwise = unwrapMonoid (stimes n (WrapMonoid x)) + +-- | 'Option' is effectively 'Maybe' with a better instance of +-- 'Monoid', built off of an underlying 'Semigroup' instead of an +-- underlying 'Monoid'. +-- +-- Ideally, this type would not exist at all and we would just fix the +-- 'Monoid' instance of 'Maybe' +newtype Option a = Option { getOption :: Maybe a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Functor Option where + fmap f (Option a) = Option (fmap f a) + +instance Applicative Option where + pure a = Option (Just a) + Option a <*> Option b = Option (a <*> b) + + Option Nothing *> _ = Option Nothing + _ *> b = b + +instance Monad Option where + Option (Just a) >>= k = k a + _ >>= _ = Option Nothing + (>>) = (*>) + +instance Alternative Option where + empty = Option Nothing + Option Nothing <|> b = b + a <|> _ = a + +instance MonadPlus Option where + mzero = Option Nothing + mplus = (<|>) + +instance MonadFix Option where + mfix f = Option (mfix (getOption . f)) + +instance Foldable Option where + foldMap f (Option (Just m)) = f m + foldMap _ (Option Nothing) = mempty + +instance Traversable Option where + traverse f (Option (Just a)) = Option . Just <$> f a + traverse _ (Option Nothing) = pure (Option Nothing) + +-- | Fold an 'Option' case-wise, just like 'maybe'. +option :: b -> (a -> b) -> Option a -> b +option n j (Option m) = maybe n j m + +instance Semigroup a => Semigroup (Option a) where + (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) + + stimes _ (Option Nothing) = Option Nothing + stimes n (Option (Just a)) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" + EQ -> Option Nothing + GT -> Option (Just (stimes n a)) + +instance Semigroup a => Monoid (Option a) where + mempty = Option Nothing + mappend = (<>) + +-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. +diff :: Semigroup m => m -> Endo m +diff = Endo . (<>) + +instance Semigroup (Proxy s) where + _ <> _ = Proxy + sconcat _ = Proxy + stimes _ _ = Proxy diff --git a/Data/String.hs b/Data/String.hs --- a/Data/String.hs +++ b/Data/String.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -27,6 +28,7 @@ ) where import GHC.Base +import Data.Functor.Const (Const (Const)) import Data.List (lines, words, unlines, unwords) -- | Class for string-like datastructures; used by the overloaded string @@ -34,6 +36,48 @@ class IsString a where fromString :: String -> a -instance IsString [Char] where +{- Note [IsString String] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, the IsString instance that covered String was a flexible +instance for [Char]. This is in some sense the most accurate choice, +but there are cases where it can lead to an ambiguity, for instance: + + show $ "foo" ++ "bar" + +The use of (++) ensures that "foo" and "bar" must have type [t] for +some t, but a flexible instance for [Char] will _only_ match if +something further determines t to be Char, and nothing in the above +example actually does. + +So, the above example generates an error about the ambiguity of t, +and what's worse, the above behavior can be generated by simply +typing: + + "foo" ++ "bar" + +into GHCi with the OverloadedStrings extension enabled. + +The new instance fixes this by defining an instance that matches all +[a], and forces a to be Char. This instance, of course, overlaps +with things that the [Char] flexible instance doesn't, but this was +judged to be an acceptable cost, for the gain of providing a less +confusing experience for people experimenting with overloaded strings. + +It may be possible to fix this via (extended) defaulting. Currently, +the rules are not able to default t to Char in the above example. If +a more flexible system that enabled this defaulting were put in place, +then it would probably make sense to revert to the flexible [Char] +instance, since extended defaulting is enabled in GHCi. However, it +is not clear at the time of this note exactly what such a system +would be, and it certainly hasn't been implemented. + +A test case (should_run/overloadedstringsrun01.hs) has been added to +ensure the good behavior of the above example remains in the future. +-} + +instance (a ~ Char) => IsString [a] where + -- See Note [IsString String] fromString xs = xs +instance IsString a => IsString (Const a b) where + fromString = Const . fromString diff --git a/Data/Traversable.hs b/Data/Traversable.hs --- a/Data/Traversable.hs +++ b/Data/Traversable.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -46,16 +50,19 @@ foldMapDefault, ) where -import Control.Applicative ( Const(..) ) +-- It is convenient to use 'Const' here but this means we must +-- define a few instances here which really belong in Control.Applicative +import Control.Applicative ( Const(..), ZipList(..) ) import Data.Either ( Either(..) ) import Data.Foldable ( Foldable ) import Data.Functor +import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) ) import Data.Proxy ( Proxy(..) ) import GHC.Arr import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), ($), (.), id, flip ) -import qualified GHC.Base as Monad ( mapM ) +import GHC.Generics import qualified GHC.List as List ( foldr ) -- | Functors representing data structures that can be traversed from @@ -103,7 +110,7 @@ -- > instance Functor Identity where -- > fmap f (Identity x) = Identity (f x) -- > --- > instance Applicative Indentity where +-- > instance Applicative Identity where -- > pure x = Identity x -- > Identity f <*> Identity x = Identity (f x) -- > @@ -179,8 +186,6 @@ traverse f = List.foldr cons_f (pure []) where cons_f x ys = (:) <$> f x <*> ys - mapM = Monad.mapM - instance Traversable (Either a) where traverse _ (Left x) = pure (Left x) traverse f (Right y) = Right <$> f y @@ -196,13 +201,57 @@ {-# 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 traverse _ (Const m) = pure $ Const m + +instance Traversable Dual where + traverse f (Dual x) = Dual <$> f x + +instance Traversable Sum where + traverse f (Sum x) = Sum <$> f x + +instance Traversable Product where + traverse f (Product x) = Product <$> f x + +instance Traversable First where + traverse f (First x) = First <$> traverse f x + +instance Traversable Last where + traverse f (Last x) = Last <$> traverse f x + +instance Traversable ZipList where + traverse f (ZipList x) = ZipList <$> traverse f x + +-- Instances for GHC.Generics +instance Traversable U1 where + traverse _ _ = pure U1 + {-# INLINE traverse #-} + sequenceA _ = pure U1 + {-# INLINE sequenceA #-} + mapM _ _ = pure U1 + {-# INLINE mapM #-} + sequence _ = pure U1 + {-# INLINE sequence #-} + +deriving instance Traversable V1 +deriving instance Traversable Par1 +deriving instance Traversable f => Traversable (Rec1 f) +deriving instance Traversable (K1 i c) +deriving instance Traversable f => Traversable (M1 i c f) +deriving instance (Traversable f, Traversable g) => Traversable (f :+: g) +deriving instance (Traversable f, Traversable g) => Traversable (f :*: g) +deriving instance (Traversable f, Traversable g) => Traversable (f :.: g) +deriving instance Traversable UAddr +deriving instance Traversable UChar +deriving instance Traversable UDouble +deriving instance Traversable UFloat +deriving instance Traversable UInt +deriving instance Traversable UWord -- general functions diff --git a/Data/Type/Bool.hs b/Data/Type/Bool.hs --- a/Data/Type/Bool.hs +++ b/Data/Type/Bool.hs @@ -28,8 +28,8 @@ -- | Type-level "If". @If True a b@ ==> @a@; @If False a b@ ==> @b@ type family If cond tru fls where - If 'True tru fls = tru - If 'False tru fls = fls + If 'True tru fls = tru + If 'False tru fls = fls -- | Type-level "and" type family a && b where diff --git a/Data/Type/Coercion.hs b/Data/Type/Coercion.hs --- a/Data/Type/Coercion.hs +++ b/Data/Type/Coercion.hs @@ -52,19 +52,17 @@ -- Steenbergen for 'type-equality', Edward Kmett for 'eq', and Gabor Greif -- for 'type-eq' -newtype Sym a b = Sym { unsym :: Coercion b a } - -- | Type-safe cast, using representational equality coerceWith :: Coercion a b -> a -> b coerceWith Coercion x = coerce x -- | Symmetry of representational equality -sym :: forall a b. Coercion a b -> Coercion b a -sym Coercion = unsym (coerce (Sym Coercion :: Sym a a)) +sym :: Coercion a b -> Coercion b a +sym Coercion = Coercion -- | Transitivity of representational equality trans :: Coercion a b -> Coercion b c -> Coercion a c -trans c Coercion = coerce c +trans Coercion Coercion = Coercion -- | Convert propositional (nominal) equality to representational equality repr :: (a Eq.:~: b) -> Coercion a b @@ -79,7 +77,7 @@ instance Coercible a b => Enum (Coercion a b) where toEnum 0 = Coercion - toEnum _ = error "Data.Type.Coercion.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Data.Type.Coercion.toEnum: bad argument" fromEnum Coercion = 0 @@ -98,4 +96,4 @@ testCoercion Eq.Refl Eq.Refl = Just Coercion instance TestCoercion (Coercion a) where - testCoercion c Coercion = Just $ coerce (sym c) + testCoercion Coercion Coercion = Just Coercion diff --git a/Data/Type/Equality.hs b/Data/Type/Equality.hs --- a/Data/Type/Equality.hs +++ b/Data/Type/Equality.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | @@ -29,9 +32,9 @@ module Data.Type.Equality ( - -- * The equality type - (:~:)(..), - + -- * The equality types + (:~:)(..), type (~~), + -- * Working with equality sym, trans, castWith, gcastWith, apply, inner, outer, @@ -49,6 +52,25 @@ import GHC.Base import Data.Type.Bool +-- | Lifted, homogeneous equality. By lifted, we mean that it can be +-- bogus (deferred type error). By homogeneous, the two types @a@ +-- and @b@ must have the same kind. +class a ~~ b => (a :: k) ~ (b :: k) | a -> b, b -> a + -- See Note [The equality types story] in TysPrim + -- NB: All this class does is to wrap its superclass, which is + -- the "real", inhomogeneous equality; this is needed when + -- we have a Given (a~b), and we want to prove things from it + -- NB: Not exported, as (~) is magical syntax. That's also why there's + -- no fixity. + +instance {-# INCOHERENT #-} a ~~ b => a ~ b + -- See Note [The equality types story] in TysPrim + -- If we have a Wanted (t1 ~ t2), we want to immediately + -- simplify it to (t1 ~~ t2) and solve that instead + -- + -- INCOHERENT because we want to use this instance eagerly, even when + -- the tyvars are partially unknown. + infix 4 :~: -- | Propositional equality. If @a :~: b@ is inhabited by some terminating @@ -57,7 +79,7 @@ -- in the body of the pattern-match, the compiler knows that @a ~ b@. -- -- @since 4.7.0.0 -data a :~: b where +data a :~: b where -- See Note [The equality types story] in TysPrim Refl :: a :~: a -- with credit to Conal Elliott for 'ty', Erik Hesselink & Martijn van @@ -101,7 +123,7 @@ instance a ~ b => Enum (a :~: b) where toEnum 0 = Refl - toEnum _ = error "Data.Type.Equality.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument" fromEnum Refl = 0 @@ -196,13 +218,13 @@ type family EqBool a b where EqBool 'True 'True = 'True EqBool 'False 'False = 'True - EqBool a b = 'False + EqBool a b = 'False type family EqOrdering a b where EqOrdering 'LT 'LT = 'True EqOrdering 'EQ 'EQ = 'True EqOrdering 'GT 'GT = 'True - EqOrdering a b = 'False + EqOrdering a b = 'False type EqUnit (a :: ()) (b :: ()) = 'True @@ -214,7 +236,7 @@ type family EqMaybe a b where EqMaybe 'Nothing 'Nothing = 'True EqMaybe ('Just x) ('Just y) = x == y - EqMaybe a b = 'False + EqMaybe a b = 'False type family Eq2 a b where Eq2 '(a1, b1) '(a2, b2) = a1 == a2 && b1 == b2 diff --git a/Data/Typeable.hs b/Data/Typeable.hs --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -58,7 +58,7 @@ -- * A canonical proxy type Proxy (..), - + -- * Type representations TypeRep, -- abstract, instance of: Eq, Show, Typeable typeRepFingerprint, @@ -66,6 +66,7 @@ showsTypeRep, TyCon, -- abstract, instance of: Eq, Show, Typeable + -- For now don't export Module, to avoid name clashes tyConFingerprint, tyConString, tyConPackage, @@ -87,7 +88,7 @@ typeRepArgs, -- :: TypeRep -> [TypeRep] ) where -import Data.Typeable.Internal hiding (mkTyCon) +import Data.Typeable.Internal import Data.Type.Equality import Unsafe.Coerce diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs --- a/Data/Typeable/Internal.hs +++ b/Data/Typeable/Internal.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -11,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | @@ -26,15 +26,25 @@ module Data.Typeable.Internal ( Proxy (..), - TypeRep(..), - KindRep, Fingerprint(..), + + -- * Typeable class typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7, Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7, - TyCon(..), + + -- * Module + Module, -- Abstract + moduleName, modulePackage, + + -- * TyCon + TyCon, -- Abstract + tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint, + mkTyCon3, mkTyCon3#, + rnfTyCon, + + -- * TypeRep + TypeRep(..), KindRep, typeRep, - mkTyCon, - mkTyCon3, mkTyConApp, mkPolyTyConApp, mkAppTy, @@ -48,17 +58,16 @@ typeRepFingerprint, rnfTypeRep, showsTypeRep, - tyConString, - rnfTyCon, - listTc, funTc, typeRepKinds, - typeLitTypeRep + typeSymbolTypeRep, typeNatTypeRep ) where import GHC.Base +import GHC.Types (TYPE) import GHC.Word import GHC.Show import Data.Proxy +import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' ) import GHC.Fingerprint.Type import {-# SOURCE #-} GHC.Fingerprint @@ -67,72 +76,155 @@ -- of Data.Typeable as much as possible so we can optimise the derived -- instances. --- | A concrete representation of a (monomorphic) type. 'TypeRep' --- supports reasonably efficient equality. -data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep] +#include "MachDeps.h" -type KindRep = TypeRep +{- ********************************************************************* +* * + The TyCon type +* * +********************************************************************* -} --- Compare keys for equality -instance Eq TypeRep where - TypeRep x _ _ _ == TypeRep y _ _ _ = x == y +modulePackage :: Module -> String +modulePackage (Module p _) = trNameString p -instance Ord TypeRep where - TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y +moduleName :: Module -> String +moduleName (Module _ m) = trNameString m +tyConPackage :: TyCon -> String +tyConPackage (TyCon _ _ m _) = modulePackage m --- | An abstract representation of a type constructor. 'TyCon' objects can --- be built using 'mkTyCon'. -data TyCon = TyCon { - tyConFingerprint :: {-# UNPACK #-} !Fingerprint, -- ^ @since 4.8.0.0 - tyConPackage :: String, -- ^ @since 4.5.0.0 - tyConModule :: String, -- ^ @since 4.5.0.0 - tyConName :: String -- ^ @since 4.5.0.0 - } +tyConModule :: TyCon -> String +tyConModule (TyCon _ _ m _) = moduleName m -instance Eq TyCon where - (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2 +tyConName :: TyCon -> String +tyConName (TyCon _ _ _ n) = trNameString n -instance Ord TyCon where - (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2 +trNameString :: TrName -> String +trNameString (TrNameS s) = unpackCString# s +trNameString (TrNameD s) = s ------------------ Construction -------------------- +-- | Observe string encoding of a type representation +{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} +-- deprecated in 7.4 +tyConString :: TyCon -> String +tyConString = tyConName -#include "MachDeps.h" +tyConFingerprint :: TyCon -> Fingerprint +tyConFingerprint (TyCon hi lo _ _) + = Fingerprint (W64# hi) (W64# lo) --- mkTyCon is an internal function to make it easier for GHC to --- generate derived instances. GHC precomputes the MD5 hash for the --- TyCon and passes it as two separate 64-bit values to mkTyCon. The --- TyCon for a derived Typeable instance will end up being statically --- allocated. +mkTyCon3# :: Addr# -- ^ package name + -> Addr# -- ^ module name + -> Addr# -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon3# pkg modl name + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name) + where + fingerprint :: Fingerprint + fingerprint = fingerprintString (unpackCString# pkg + ++ (' ': unpackCString# modl) + ++ (' ' : unpackCString# name)) -#if WORD_SIZE_IN_BITS < 64 -mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon -#else -mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon -#endif -mkTyCon high# low# pkg modl name - = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name +mkTyCon3 :: String -- ^ package name + -> String -- ^ module name + -> String -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +-- Used when the strings are dynamically allocated, +-- eg from binary deserialisation +mkTyCon3 pkg modl name + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name) + where + fingerprint :: Fingerprint + fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name)) --- | Applies a polymorhic type constructor to a sequence of kinds and types +isTupleTyCon :: TyCon -> Bool +isTupleTyCon tc + | ('(':',':_) <- tyConName tc = True + | otherwise = False + +-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation +-- +-- @since 4.8.0.0 +rnfModule :: Module -> () +rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m + +rnfTrName :: TrName -> () +rnfTrName (TrNameS _) = () +rnfTrName (TrNameD n) = rnfString n + +rnfTyCon :: TyCon -> () +rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n + +rnfString :: [Char] -> () +rnfString [] = () +rnfString (c:cs) = c `seq` rnfString cs + + +{- ********************************************************************* +* * + The TypeRep type +* * +********************************************************************* -} + +-- | A concrete representation of a (monomorphic) type. +-- 'TypeRep' supports reasonably efficient equality. +data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep] + -- NB: For now I've made this lazy so that it's easy to + -- optimise code that constructs and deconstructs TypeReps + -- perf/should_run/T9203 is a good example + -- Also note that mkAppTy does discards the fingerprint, + -- so it's a waste to compute it + +type KindRep = TypeRep + +-- Compare keys for equality +instance Eq TypeRep where + TypeRep x _ _ _ == TypeRep y _ _ _ = x == y + +instance Ord TypeRep where + TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y + +-- | Observe the 'Fingerprint' of a type representation +-- +-- @since 4.8.0.0 +typeRepFingerprint :: TypeRep -> Fingerprint +typeRepFingerprint (TypeRep fpr _ _ _) = fpr + +-- | Applies a kind-polymorphic type constructor to a sequence of kinds and +-- types mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep -mkPolyTyConApp tc@(TyCon tc_k _ _ _) [] [] = TypeRep tc_k tc [] [] -mkPolyTyConApp tc@(TyCon tc_k _ _ _) kinds types = - TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc kinds types +{-# INLINE mkPolyTyConApp #-} +mkPolyTyConApp tc kinds types + = TypeRep (fingerprintFingerprints sub_fps) tc kinds types where - arg_ks = [ k | TypeRep k _ _ _ <- kinds ++ types ] + !kt_fps = typeRepFingerprints kinds types + sub_fps = tyConFingerprint tc : kt_fps --- | Applies a monomorphic type constructor to a sequence of types +typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint] +-- Builds no thunks +typeRepFingerprints kinds types + = go1 [] kinds + where + go1 acc [] = go2 acc types + go1 acc (k:ks) = let !fp = typeRepFingerprint k + in go1 (fp:acc) ks + go2 acc [] = acc + go2 acc (t:ts) = let !fp = typeRepFingerprint t + in go2 (fp:acc) ts + +-- | Applies a kind-monomorphic type constructor to a sequence of types mkTyConApp :: TyCon -> [TypeRep] -> TypeRep mkTyConApp tc = mkPolyTyConApp tc [] -- | A special case of 'mkTyConApp', which applies the function -- type constructor to a pair of types. mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkTyConApp funTc [f,a] +mkFunTy f a = mkTyConApp tcFun [f,a] -- | Splits a type constructor application. --- Note that if the type construcotr is polymorphic, this will +-- Note that if the type constructor is polymorphic, this will -- not return the kinds that were used. -- See 'splitPolyTyConApp' if you need all parts. splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) @@ -149,11 +241,18 @@ funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep funResultTy trFun trArg = case splitTyConApp trFun of - (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2 _ -> Nothing +tyConOf :: Typeable a => Proxy a -> TyCon +tyConOf = typeRepTyCon . typeRep + +tcFun :: TyCon +tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) + -- | Adds a TypeRep argument to a TypeRep. mkAppTy :: TypeRep -> TypeRep -> TypeRep +{-# INLINE mkAppTy #-} mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr]) -- Notice that we call mkTyConApp to construct the fingerprint from tc and -- the arg fingerprints. Simply combining the current fingerprint with @@ -161,20 +260,6 @@ -- ensure that a TypeRep of the same shape has the same fingerprint! -- See Trac #5962 --- | Builds a 'TyCon' object representing a type constructor. An --- implementation of "Data.Typeable" should ensure that the following holds: --- --- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C' --- - --- -mkTyCon3 :: String -- ^ package name - -> String -- ^ module name - -> String -- ^ the name of the type constructor - -> TyCon -- ^ A unique 'TyCon' object -mkTyCon3 pkg modl name = - TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name - ----------------- Observation --------------------- -- | Observe the type constructor of a type representation @@ -189,16 +274,12 @@ typeRepKinds :: TypeRep -> [KindRep] typeRepKinds (TypeRep _ _ ks _) = ks --- | Observe string encoding of a type representation -{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} -- deprecated in 7.4 -tyConString :: TyCon -> String -tyConString = tyConName --- | Observe the 'Fingerprint' of a type representation --- --- @since 4.8.0.0 -typeRepFingerprint :: TypeRep -> Fingerprint -typeRepFingerprint (TypeRep fpr _ _ _) = fpr +{- ********************************************************************* +* * + The Typeable class +* * +********************************************************************* -} ------------------------------------------------------------- -- @@ -272,8 +353,20 @@ showsPrec p (TypeRep _ tycon kinds tys) = case tys of [] -> showsPrec p tycon - [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' - [a,r] | tycon == funTc -> showParen (p > 8) $ + [x] + | tycon == tcList -> showChar '[' . shows x . showChar ']' + where + tcList = tyConOf @[] Proxy + [TypeRep _ ptrRepCon _ []] + | tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted + -> showChar '*' + | tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted + -> showChar '#' + where + tcTYPE = tyConOf @TYPE Proxy + tc'PtrRepLifted = tyConOf @'PtrRepLifted Proxy + tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy + [a,r] | tycon == tcFun -> showParen (p > 8) $ showsPrec 9 a . showString " -> " . showsPrec 8 r @@ -287,13 +380,6 @@ showsTypeRep :: TypeRep -> ShowS showsTypeRep = shows -instance Show TyCon where - showsPrec _ t = showString (tyConName t) - -isTupleTyCon :: TyCon -> Bool -isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True -isTupleTyCon _ = False - -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation -- -- @since 4.8.0.0 @@ -303,15 +389,6 @@ go [] = () go (x:xs) = rnfTypeRep x `seq` go xs --- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation --- --- @since 4.8.0.0 -rnfTyCon :: TyCon -> () -rnfTyCon (TyCon _ tcp tcm tcn) = go tcp `seq` go tcm `seq` go tcn - where - go [] = () - go (x:xs) = x `seq` go xs - -- Some (Show.TypeRep) helpers: showArgs :: Show a => ShowS -> [a] -> ShowS @@ -324,27 +401,25 @@ . showArgs (showChar ',') args . showChar ')' -listTc :: TyCon -listTc = typeRepTyCon (typeOf [()]) +{- ********************************************************* +* * +* TyCon/TypeRep definitions for type literals * +* (Symbol and Nat) * +* * +********************************************************* -} -funTc :: TyCon -funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->))) +mkTypeLitTyCon :: String -> TyCon +mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name +-- | Used to make `'Typeable' instance for things of kind Nat +typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep +typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) +-- | Used to make `'Typeable' instance for things of kind Symbol +typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep +typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) + -- | An internal function, to make representations for type literals. typeLitTypeRep :: String -> TypeRep -typeLitTypeRep nm = rep - where - rep = mkTyConApp tc [] - tc = TyCon - { tyConFingerprint = fingerprintString (mk pack modu nm) - , tyConPackage = pack - , tyConModule = modu - , tyConName = nm - } - pack = "base" - modu = "GHC.TypeLits" - mk a b c = a ++ " " ++ b ++ " " ++ c - - +typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) [] diff --git a/Data/Unique.hs b/Data/Unique.hs --- a/Data/Unique.hs +++ b/Data/Unique.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE MagicHash, AutoDeriveTypeable #-} +{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -26,12 +26,11 @@ import GHC.Base import GHC.Num -import Data.Typeable import Data.IORef -- | An abstract unique object. Objects of type 'Unique' may be -- compared for equality and ordering and hashed into 'Int'. -newtype Unique = Unique Integer deriving (Eq,Ord,Typeable) +newtype Unique = Unique Integer deriving (Eq,Ord) uniqSource :: IORef Integer uniqSource = unsafePerformIO (newIORef 0) diff --git a/Data/Version.hs b/Data/Version.hs --- a/Data/Version.hs +++ b/Data/Version.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-} -{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} ----------------------------------------------------------------------------- @@ -36,7 +36,8 @@ 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 @@ -44,7 +45,7 @@ import Data.List import Data.Ord import Data.String ( String ) -import Data.Typeable ( Typeable ) +import GHC.Generics import GHC.Read import GHC.Show import Text.ParserCombinators.ReadP @@ -93,9 +94,9 @@ -- The interpretation of the list of tags is entirely dependent -- on the entity that this version applies to. } - deriving (Read,Show,Typeable) + deriving (Read,Show,Generic) {-# DEPRECATED versionTags "See GHC ticket #2496" #-} --- TODO. Remove all references to versionTags in GHC 7.12 release. +-- TODO. Remove all references to versionTags in GHC 8.0 release. instance Eq Version where v1 == v2 = versionBranch v1 == versionBranch v2 @@ -120,9 +121,9 @@ -- | 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/Data/Void.hs b/Data/Void.hs --- a/Data/Void.hs +++ b/Data/Void.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} diff --git a/Debug/Trace.hs b/Debug/Trace.hs --- a/Debug/Trace.hs +++ b/Debug/Trace.hs @@ -149,10 +149,16 @@ traceShowId a = trace (show a) a {-| -Like 'trace' but returning unit in an arbitrary monad. Allows for convenient -use in do-notation. Note that the application of 'trace' is not an action in the -monad, as 'traceIO' is in the 'IO' monad. +Like 'trace' but returning unit in an arbitrary 'Applicative' context. Allows +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 <- ... > traceM $ "x: " ++ show x @@ -161,28 +167,28 @@ @since 4.7.0.0 -} -traceM :: (Monad m) => String -> m () -traceM string = trace string $ return () +traceM :: (Applicative f) => String -> f () +traceM string = trace string $ pure () {-| Like 'traceM', but uses 'show' on the argument to convert it to a 'String'. > ... = do > x <- ... -> traceMShow $ x +> traceShowM $ x > y <- ... -> traceMShow $ x + y +> traceShowM $ x + y @since 4.7.0.0 -} -traceShowM :: (Show a, Monad m) => a -> m () +traceShowM :: (Show a, Applicative f) => a -> f () traceShowM = traceM . show -- | like 'trace', but additionally prints a call stack if one is -- available. -- -- In the current GHC implementation, the call stack is only --- availble if the program was compiled with @-prof@; otherwise +-- available if the program was compiled with @-prof@; otherwise -- 'traceStack' behaves exactly like 'trace'. Entries in the call -- stack correspond to @SCC@ annotations, so it is a good idea to use -- @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically. diff --git a/Foreign/C/Types.hs b/Foreign/C/Types.hs --- a/Foreign/C/Types.hs +++ b/Foreign/C/Types.hs @@ -1,8 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, GeneralizedNewtypeDeriving, - AutoDeriveTypeable, StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} --- XXX -fno-warn-unused-binds stops us warning about unused constructors, + StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-unused-binds #-} +-- XXX -Wno-unused-binds stops us warning about unused constructors, -- but really we should just remove them if we don't want them ----------------------------------------------------------------------------- @@ -24,7 +24,7 @@ -- $ctypes -- ** Integral types - -- | These types are are represented as @newtype@s of + -- | These types are represented as @newtype@s of -- types in "Data.Int" and "Data.Word", and are instances of -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable', @@ -53,7 +53,7 @@ -- -- ** Floating types - -- | These types are are represented as @newtype@s of + -- | These types are represented as @newtype@s of -- 'Prelude.Float' and 'Prelude.Double', and are instances of -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable', @@ -73,7 +73,6 @@ import Data.Bits ( Bits(..), FiniteBits(..) ) import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.Word ( Word8, Word16, Word32, Word64 ) -import Data.Typeable import GHC.Base import GHC.Float diff --git a/Foreign/Marshal/Array.hs b/Foreign/Marshal/Array.hs --- a/Foreign/Marshal/Array.hs +++ b/Foreign/Marshal/Array.hs @@ -211,8 +211,7 @@ withArrayLen vals f = allocaArray len $ \ptr -> do pokeArray ptr vals - res <- f len ptr - return res + f len ptr where len = length vals diff --git a/Foreign/Marshal/Error.hs b/Foreign/Marshal/Error.hs --- a/Foreign/Marshal/Error.hs +++ b/Foreign/Marshal/Error.hs @@ -30,10 +30,6 @@ import Foreign.Ptr -#ifdef __HADDOCK__ -import Data.Bool -import System.IO.Error -#endif import GHC.Base import GHC.Num import GHC.IO.Exception diff --git a/Foreign/Ptr.hs b/Foreign/Ptr.hs --- a/Foreign/Ptr.hs +++ b/Foreign/Ptr.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, GeneralizedNewtypeDeriving, - AutoDeriveTypeable, StandaloneDeriving #-} + StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -58,7 +58,6 @@ import GHC.Enum import Data.Bits -import Data.Typeable import Foreign.Storable ( Storable(..) ) -- | Release the storage associated with the given 'FunPtr', which diff --git a/Foreign/Storable.hs b/Foreign/Storable.hs --- a/Foreign/Storable.hs +++ b/Foreign/Storable.hs @@ -145,6 +145,12 @@ peek ptr = peekElemOff ptr 0 poke ptr = pokeElemOff ptr 0 +instance Storable () where + sizeOf _ = 0 + alignment _ = 1 + peek _ = return () + poke _ _ = return () + -- System-dependent, but rather obvious instances instance Storable Bool where diff --git a/GHC/Arr.hs b/GHC/Arr.hs --- a/GHC/Arr.hs +++ b/GHC/Arr.hs @@ -173,13 +173,13 @@ {-# NOINLINE indexError #-} indexError :: Show a => (a,a) -> a -> String -> b indexError rng i tp - = error (showString "Ix{" . showString tp . showString "}.index: Index " . + = errorWithoutStackTrace (showString "Ix{" . showString tp . showString "}.index: Index " . showParen True (showsPrec 0 i) . showString " out of range " $ showParen True (showsPrec 0 rng) "") hopelessIndexError :: Int -- Try to use 'indexError' instead! -hopelessIndexError = error "Error in array index" +hopelessIndexError = errorWithoutStackTrace "Error in array index" ---------------------------------------------------------------------- instance Ix Char where @@ -399,7 +399,7 @@ {-# NOINLINE arrEleBottom #-} arrEleBottom :: a -arrEleBottom = error "(Array.!): undefined array element" +arrEleBottom = errorWithoutStackTrace "(Array.!): undefined array element" -- | Construct an array with the specified bounds and containing values -- for given indices within these bounds. @@ -450,7 +450,7 @@ unsafeArray b ies = unsafeArray' b (rangeSize b) ies {-# INLINE unsafeArray' #-} -unsafeArray' :: Ix i => (i,i) -> Int -> [(Int, e)] -> Array i e +unsafeArray' :: (i,i) -> Int -> [(Int, e)] -> Array i e unsafeArray' (l,u) n@(I# n#) ies = runST (ST $ \s1# -> case newArray# n# arrEleBottom s1# of (# s2#, marr# #) -> @@ -465,7 +465,7 @@ s2# -> next s2# {-# INLINE done #-} -done :: Ix i => i -> i -> Int -> MutableArray# s e -> STRep s (Array i e) +done :: i -> i -> Int -> MutableArray# s e -> STRep s (Array i e) -- See NB on 'fill' -- Make sure it is strict in 'n' done l u n@(I# _) marr# @@ -504,7 +504,7 @@ -- Don't inline this error message everywhere!! negRange :: Int -- Uninformative, but Ix does not provide Show -negRange = error "Negative range size" +negRange = errorWithoutStackTrace "Negative range size" {-# INLINE[1] safeIndex #-} -- See Note [Double bounds-checking of index values] @@ -531,22 +531,22 @@ -- Don't inline this long error message everywhere!! badSafeIndex :: Int -> Int -> Int -badSafeIndex i' n = error ("Error in array index; " ++ show i' ++ +badSafeIndex i' n = errorWithoutStackTrace ("Error in array index; " ++ show i' ++ " not in range [0.." ++ show n ++ ")") {-# INLINE unsafeAt #-} -unsafeAt :: Ix i => Array i e -> Int -> e +unsafeAt :: Array i e -> Int -> e unsafeAt (Array _ _ _ arr#) (I# i#) = case indexArray# arr# i# of (# e #) -> e -- | The bounds with which an array was constructed. {-# INLINE bounds #-} -bounds :: Ix i => Array i e -> (i,i) +bounds :: Array i e -> (i,i) bounds (Array l u _ _) = (l,u) -- | The number of elements in the array. {-# INLINE numElements #-} -numElements :: Ix i => Array i e -> Int +numElements :: Array i e -> Int numElements (Array _ _ n _) = n -- | The list of indices of an array in ascending order. @@ -556,13 +556,13 @@ -- | The list of elements of an array in index order. {-# INLINE elems #-} -elems :: Ix i => Array i e -> [e] +elems :: Array i e -> [e] elems arr@(Array _ _ n _) = [unsafeAt arr i | i <- [0 .. n - 1]] -- | A right fold over the elements {-# INLINABLE foldrElems #-} -foldrElems :: Ix i => (a -> b -> b) -> b -> Array i a -> b +foldrElems :: (a -> b -> b) -> b -> Array i a -> b foldrElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == n = b0 @@ -571,7 +571,7 @@ -- | A left fold over the elements {-# INLINABLE foldlElems #-} -foldlElems :: Ix i => (b -> a -> b) -> b -> Array i a -> b +foldlElems :: (b -> a -> b) -> b -> Array i a -> b foldlElems f b0 = \ arr@(Array _ _ n _) -> let go i | i == (-1) = b0 @@ -580,7 +580,7 @@ -- | A strict right fold over the elements {-# INLINABLE foldrElems' #-} -foldrElems' :: Ix i => (a -> b -> b) -> b -> Array i a -> b +foldrElems' :: (a -> b -> b) -> b -> Array i a -> b foldrElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == (-1) = a @@ -589,7 +589,7 @@ -- | A strict left fold over the elements {-# INLINABLE foldlElems' #-} -foldlElems' :: Ix i => (b -> a -> b) -> b -> Array i a -> b +foldlElems' :: (b -> a -> b) -> b -> Array i a -> b foldlElems' f b0 = \ arr@(Array _ _ n _) -> let go i a | i == n = a @@ -598,23 +598,23 @@ -- | A left fold over the elements with no starting value {-# INLINABLE foldl1Elems #-} -foldl1Elems :: Ix i => (a -> a -> a) -> Array i a -> a +foldl1Elems :: (a -> a -> a) -> Array i a -> a foldl1Elems f = \ arr@(Array _ _ n _) -> let go i | i == 0 = unsafeAt arr 0 | otherwise = f (go (i-1)) (unsafeAt arr i) in - if n == 0 then error "foldl1: empty Array" else go (n-1) + if n == 0 then errorWithoutStackTrace "foldl1: empty Array" else go (n-1) -- | A right fold over the elements with no starting value {-# INLINABLE foldr1Elems #-} -foldr1Elems :: Ix i => (a -> a -> a) -> Array i a -> a +foldr1Elems :: (a -> a -> a) -> Array i a -> a foldr1Elems f = \ arr@(Array _ _ n _) -> let go i | i == n-1 = unsafeAt arr i | otherwise = f (unsafeAt arr i) (go (i + 1)) in - if n == 0 then error "foldr1: empty Array" else go 0 + if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0 -- | The list of associations of an array in index order. {-# INLINE assocs #-} @@ -653,7 +653,7 @@ unsafeAccumArray f initial b ies = unsafeAccumArray' f initial b (rangeSize b) ies {-# INLINE unsafeAccumArray' #-} -unsafeAccumArray' :: Ix i => (e -> a -> e) -> e -> (i,i) -> Int -> [(Int, a)] -> Array i e +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# }) @@ -684,7 +684,7 @@ unsafeReplace arr [(safeIndex (l,u) n i, e) | (i, e) <- ies] {-# INLINE unsafeReplace #-} -unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e +unsafeReplace :: Array i e -> [(Int, e)] -> Array i e unsafeReplace arr ies = runST (do STArray l u n marr# <- thawSTArray arr ST (foldr (fill marr#) (done l u n marr#) ies)) @@ -701,13 +701,13 @@ unsafeAccum f arr [(safeIndex (l,u) n i, e) | (i, e) <- ies] {-# INLINE unsafeAccum #-} -unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e +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)) -{-# INLINE [1] amap #-} -amap :: Ix i => (a -> b) -> Array i a -> Array i b +{-# INLINE [1] amap #-} -- See Note [amap] +amap :: (a -> b) -> Array i a -> Array i b amap f arr@(Array l u n@(I# n#) _) = runST (ST $ \s1# -> case newArray# n# arrEleBottom s1# of (# s2#, marr# #) -> @@ -716,7 +716,8 @@ | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s# in go 0 s2# ) -{- +{- Note [amap] +~~~~~~~~~~~~~~ amap was originally defined like this: amap f arr@(Array l u n _) = @@ -725,11 +726,12 @@ There are two problems: 1. The enumFromTo implementation produces (spurious) code for the impossible -case of n<0 that ends up duplicating the array freezing code. + case of n<0 that ends up duplicating the array freezing code. -2. This implementation relies on list fusion for efficiency. In order to -implement the amap/coerce rule, we need to delay inlining amap until simplifier -phase 1, which is when the eftIntList rule kicks in and makes that impossible. +2. This implementation relies on list fusion for efficiency. In order + to implement the "amap/coerce" rule, we need to delay inlining amap + until simplifier phase 1, which is when the eftIntList rule kicks + in and makes that impossible. (c.f. Trac #8767) -} @@ -737,7 +739,7 @@ -- Coercions for Haskell", section 6.5: -- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf {-# RULES -"amap/coerce" amap coerce = coerce +"amap/coerce" amap coerce = coerce -- See Note [amap] #-} -- Second functor law: @@ -786,7 +788,7 @@ ---------------------------------------------------------------------- -- Array instances -instance Ix i => Functor (Array i) where +instance Functor (Array i) where fmap = amap instance (Ix i, Eq e) => Eq (Array i e) where @@ -845,7 +847,7 @@ unsafeReadSTArray marr (safeIndex (l,u) n i) {-# INLINE unsafeReadSTArray #-} -unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e +unsafeReadSTArray :: STArray s i e -> Int -> ST s e unsafeReadSTArray (STArray _ _ _ marr#) (I# i#) = ST $ \s1# -> readArray# marr# i# s1# @@ -855,7 +857,7 @@ unsafeWriteSTArray marr (safeIndex (l,u) n i) e {-# INLINE unsafeWriteSTArray #-} -unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s () +unsafeWriteSTArray :: STArray s i e -> Int -> e -> ST s () unsafeWriteSTArray (STArray _ _ _ marr#) (I# i#) e = ST $ \s1# -> case writeArray# marr# i# e s1# of s2# -> (# s2#, () #) @@ -863,7 +865,7 @@ ---------------------------------------------------------------------- -- Moving between mutable and immutable -freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e) +freezeSTArray :: STArray s i e -> ST s (Array i e) freezeSTArray (STArray l u n@(I# n#) marr#) = ST $ \s1# -> case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) -> let copy i# s3# | isTrue# (i# ==# n#) = s3# @@ -876,12 +878,12 @@ (# s4#, Array l u n arr# #) }}} {-# INLINE unsafeFreezeSTArray #-} -unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e) +unsafeFreezeSTArray :: STArray s i e -> ST s (Array i e) unsafeFreezeSTArray (STArray l u n marr#) = ST $ \s1# -> case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> (# s2#, Array l u n arr# #) } -thawSTArray :: Ix i => Array i e -> ST s (STArray s i e) +thawSTArray :: Array i e -> ST s (STArray s i e) thawSTArray (Array l u n@(I# n#) arr#) = ST $ \s1# -> case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> let copy i# s3# | isTrue# (i# ==# n#) = s3# @@ -893,7 +895,7 @@ (# s3#, STArray l u n marr# #) }} {-# INLINE unsafeThawSTArray #-} -unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e) +unsafeThawSTArray :: Array i e -> ST s (STArray s i e) unsafeThawSTArray (Array l u n arr#) = ST $ \s1# -> case unsafeThawArray# arr# s1# of { (# s2#, marr# #) -> (# s2#, STArray l u n marr# #) } diff --git a/GHC/Base.hs b/GHC/Base.hs --- a/GHC/Base.hs +++ b/GHC/Base.hs @@ -1,4 +1,17 @@ {- + +NOTA BENE: Do NOT use ($) anywhere in this module! The type of ($) is +slightly magical (it can return unlifted types), and it is wired in. +But, it is also *defined* in this module, with a non-magical type. +GHC gets terribly confused (and *hangs*) if you try to use ($) in this +module, because it has different types in different scenarios. + +This is not a problem in general, because the type ($), being wired in, is not +written out to the interface file, so importing files don't get confused. +The problem is only if ($) is used here. So don't! + +--------------------------------------------- + The overall structure of the GHC Prelude is a bit tricky. a) We want to avoid "orphan modules", i.e. ones with instance @@ -71,9 +84,9 @@ , ExistentialQuantification , RankNTypes #-} --- -fno-warn-orphans is needed for things like: +-- -Wno-orphans is needed for things like: -- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -111,7 +124,7 @@ import GHC.Magic import GHC.Prim import GHC.Err -import {-# SOURCE #-} GHC.IO (failIO) +import {-# SOURCE #-} GHC.IO (failIO,mplusIO) import GHC.Tuple () -- Note [Depend on GHC.Tuple] import GHC.Integer () -- Note [Depend on GHC.Integer] @@ -134,7 +147,7 @@ GHC.Integer.Type.mkInteger to construct Integer literal values Currently it reads the interface file whether or not the current module *has* any Integer literals, so it's important that -GHC.Integer.Type (in patckage integer-gmp or integer-simple) is +GHC.Integer.Type (in package integer-gmp or integer-simple) is compiled before any other module. (There's a hack in GHC to disable this for packages ghc-prim, integer-gmp, integer-simple, which aren't allowed to contain any Integer literals.) @@ -174,8 +187,8 @@ (&&) True True = True otherwise = True -build = error "urk" -foldr = error "urk" +build = errorWithoutStackTrace "urk" +foldr = errorWithoutStackTrace "urk" #endif -- | The 'Maybe' type encapsulates an optional value. A value of type @@ -308,7 +321,13 @@ pure x = (mempty, x) (u, f) <*> (v, x) = (u `mappend` v, f x) +instance Monoid a => Monad ((,) a) where + (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) +instance Monoid a => Monoid (IO a) where + mempty = pure mempty + mappend = liftA2 mappend + {- | The 'Functor' class is used for types that can be mapped over. Instances of 'Functor' should satisfy the following laws: @@ -473,8 +492,13 @@ -- | Fail with a message. This operation is not part of the -- mathematical definition of a monad, but is invoked on pattern-match -- failure in a @do@ expression. + -- + -- As part of the MonadFail proposal (MFP), this function is moved + -- to its own class 'MonadFail' (see "Control.Monad.Fail" for more + -- details). The definition here will be removed in a future + -- release. fail :: String -> m a - fail s = error s + fail s = errorWithoutStackTrace s {- Note [Recursive bindings for Applicative/Monad] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -619,7 +643,6 @@ (<*>) f g x = f x (g x) instance Monad ((->) r) where - return = const f >>= k = \ r -> k (f r) r instance Functor ((,) a) where @@ -645,7 +668,6 @@ (>>) = (*>) - return = Just fail _ = Nothing -- ----------------------------------------------------------------------------- @@ -728,8 +750,6 @@ xs >>= f = [y | x <- xs, y <- f x] {-# INLINE (>>) #-} (>>) = (*>) - {-# INLINE return #-} - return x = [x] {-# INLINE fail #-} fail _ = [] @@ -846,9 +866,10 @@ -- > map f [x1, x2, ...] == [f x1, f x2, ...] map :: (a -> b) -> [a] -> [b] -{-# NOINLINE [1] map #-} -- We want the RULE to fire first. - -- It's recursive, so won't inline anyway, - -- but saying so is more explicit +{-# NOINLINE [0] map #-} + -- We want the RULEs "map" and "map/coerce" to fire first. + -- map is recursive, so won't inline anyway, + -- but saying so is more explicit, and silences warnings map _ [] = [] map f (x:xs) = f x : map f xs @@ -1002,7 +1023,12 @@ data Opaque = forall a. O a --- | Constant function. +-- | @const x@ is a unary function which evaluates to @x@ for all inputs. +-- +-- For instance, +-- +-- >>> map (const 42) [0..3] +-- [42,42,42,42] const :: a -> b -> a const x _ = x @@ -1055,29 +1081,36 @@ ---------------------------------------------- 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 +instance Alternative IO where + empty = failIO "mzero" + (<|>) = mplusIO + +instance MonadPlus IO + returnIO :: a -> IO a -returnIO x = IO $ \ s -> (# s, x #) +returnIO x = IO (\ s -> (# s, x #)) bindIO :: IO a -> (a -> IO b) -> IO b -bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s +bindIO (IO m) k = IO (\ s -> case m s of (# new_s, a #) -> unIO (k a) new_s) thenIO :: IO a -> IO b -> IO b -thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s +thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s) unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) unIO (IO a) = a @@ -1189,11 +1222,3 @@ -- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n #-} - - -#ifdef __HADDOCK__ --- | A special argument for the 'Control.Monad.ST.ST' type constructor, --- indexing a state embedded in the 'Prelude.IO' monad by --- 'Control.Monad.ST.stToIO'. -data RealWorld -#endif diff --git a/GHC/Char.hs b/GHC/Char.hs --- a/GHC/Char.hs +++ b/GHC/Char.hs @@ -1,8 +1,15 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash #-} -module GHC.Char (chr) where +module GHC.Char + ( -- * Utilities + chr + -- * Monomorphic equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + , eqChar, neChar + ) where + import GHC.Base import GHC.Show @@ -11,5 +18,5 @@ chr i@(I# i#) | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#) | otherwise - = error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") + = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "") diff --git a/GHC/Conc.hs b/GHC/Conc.hs --- a/GHC/Conc.hs +++ b/GHC/Conc.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- diff --git a/GHC/Conc/IO.hs b/GHC/Conc/IO.hs --- a/GHC/Conc/IO.hs +++ b/GHC/Conc/IO.hs @@ -4,7 +4,7 @@ , MagicHash , UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -198,6 +198,6 @@ #else | threaded = Event.registerDelay usecs #endif - | otherwise = error "registerDelay: requires -threaded" + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool diff --git a/GHC/Conc/Signal.hs b/GHC/Conc/Signal.hs --- a/GHC/Conc/Signal.hs +++ b/GHC/Conc/Signal.hs @@ -55,7 +55,7 @@ let int = fromIntegral sig withMVar signal_handlers $ \arr -> if not (inRange (boundsIOArray arr) int) - then error "GHC.Conc.setHandler: signal out of range" + then errorWithoutStackTrace "GHC.Conc.setHandler: signal out of range" else do old <- unsafeReadIOArray arr int unsafeWriteIOArray arr int handler return old diff --git a/GHC/Conc/Sync.hs b/GHC/Conc/Sync.hs --- a/GHC/Conc/Sync.hs +++ b/GHC/Conc/Sync.hs @@ -5,11 +5,10 @@ , MagicHash , UnboxedTuples , UnliftedFFITypes - , DeriveDataTypeable , StandaloneDeriving , RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -126,7 +125,7 @@ -- 'ThreadId', 'par', and 'fork' ----------------------------------------------------------------------------- -data ThreadId = ThreadId ThreadId# deriving( Typeable ) +data ThreadId = ThreadId ThreadId# -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. @@ -214,7 +213,9 @@ -- to 100K, but tunable with the @+RTS -xq@ option) so that it can handle -- the exception and perform any necessary clean up. If it exhausts -- this additional allowance, another 'AllocationLimitExceeded' exception --- is sent, and so forth. +-- is sent, and so forth. Like other asynchronous exceptions, the +-- 'AllocationLimitExceeded' exception is deferred while the thread is inside +-- 'mask' or an exception handler in 'catch'. -- -- Note that memory allocation is unrelated to /live memory/, also -- known as /heap residency/. A thread can allocate a large amount of @@ -620,25 +621,24 @@ -- |A monad supporting atomic memory transactions. newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) - deriving Typeable 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 -> @@ -750,7 +750,7 @@ -- subsequent transcations, (ii) the invariant failure is indicated -- by raising an exception. checkInv :: STM a -> STM () -checkInv (STM m) = STM (\s -> (check# m) s) +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 @@ -766,11 +766,10 @@ -- 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 ( error "Transactional invariant violation" ) ) + if (v) then return () else ( errorWithoutStackTrace "Transactional invariant violation" ) ) -- |Shared memory locations that support atomic memory transactions. data TVar a = TVar (TVar# RealWorld a) - deriving Typeable instance Eq (TVar a) where (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#) @@ -878,9 +877,7 @@ (hFlush stdout) `catchAny` (\ _ -> return ()) let msg = case cast ex of Just Deadlock -> "no threads to run: infinite loop or deadlock?" - _ -> case cast ex of - Just (ErrorCall s) -> s - _ -> showsPrec 0 se "" + _ -> showsPrec 0 se "" withCString "%s" $ \cfmt -> withCString msg $ \cmsg -> errorBelch cfmt cmsg diff --git a/GHC/Conc/Windows.hs b/GHC/Conc/Windows.hs --- a/GHC/Conc/Windows.hs +++ b/GHC/Conc/Windows.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, - AutoDeriveTypeable #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -40,7 +39,6 @@ ) where import Data.Bits (shiftR) -import Data.Typeable import GHC.Base import GHC.Conc.Sync import GHC.Enum (Enum) @@ -125,7 +123,7 @@ registerDelay :: Int -> IO (TVar Bool) registerDelay usecs | threaded = waitForDelayEventSTM usecs - | otherwise = error "registerDelay: requires -threaded" + | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool @@ -280,7 +278,7 @@ -- these are sent to Services only. | Logoff | Shutdown - deriving (Eq, Ord, Enum, Show, Read, Typeable) + deriving (Eq, Ord, Enum, Show, Read) start_console_handler :: Word32 -> IO () start_console_handler r = @@ -301,7 +299,7 @@ _ -> Nothing win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) -win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler")) +win32ConsoleHandler = unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler")) wakeupIOManager :: IO () wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs --- a/GHC/ConsoleHandler.hs +++ b/GHC/ConsoleHandler.hs @@ -19,7 +19,7 @@ ----------------------------------------------------------------------------- module GHC.ConsoleHandler -#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__) +#if !defined(mingw32_HOST_OS) where import GHC.Base () -- dummy dependency @@ -96,7 +96,7 @@ STG_SIG_DFL -> return Default STG_SIG_IGN -> return Ignore STG_SIG_HAN -> return (Catch old_h) - _ -> error "installHandler: Bad threaded rc value" + _ -> errorWithoutStackTrace "installHandler: Bad threaded rc value" return (new_h, prev_handler) | otherwise = @@ -118,7 +118,7 @@ -- stable pointer is no longer in use, free it. freeStablePtr osptr return (Catch (\ ev -> oldh (fromConsoleEvent ev))) - _ -> error "installHandler: Bad non-threaded rc value" + _ -> errorWithoutStackTrace "installHandler: Bad non-threaded rc value" where fromConsoleEvent ev = case ev of @@ -135,7 +135,7 @@ Just x -> hdlr x >> rts_ConsoleHandlerDone ev Nothing -> return () -- silently ignore.. - no_handler = error "win32ConsoleHandler" + no_handler = errorWithoutStackTrace "win32ConsoleHandler" foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool diff --git a/GHC/Enum.hs b/GHC/Enum.hs --- a/GHC/Enum.hs +++ b/GHC/Enum.hs @@ -123,7 +123,7 @@ {-# NOINLINE toEnumError #-} toEnumError :: (Show a) => String -> Int -> (a,a) -> b toEnumError inst_ty i bnds = - error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++ + errorWithoutStackTrace $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++ show i ++ ") is outside of bounds " ++ show bnds @@ -131,7 +131,7 @@ {-# NOINLINE fromEnumError #-} fromEnumError :: (Show a) => String -> a -> b fromEnumError inst_ty x = - error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++ + errorWithoutStackTrace $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++ show x ++ ") is outside of Int's bounds " ++ show (minBound::Int, maxBound::Int) @@ -139,12 +139,12 @@ {-# NOINLINE succError #-} succError :: String -> a succError inst_ty = - error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound" + errorWithoutStackTrace $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound" {-# NOINLINE predError #-} predError :: String -> a predError inst_ty = - error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound" + errorWithoutStackTrace $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound" ------------------------------------------------------------------------ -- Tuples @@ -155,11 +155,11 @@ maxBound = () instance Enum () where - succ _ = error "Prelude.Enum.().succ: bad argument" - pred _ = error "Prelude.Enum.().pred: bad argument" + succ _ = errorWithoutStackTrace "Prelude.Enum.().succ: bad argument" + pred _ = errorWithoutStackTrace "Prelude.Enum.().pred: bad argument" toEnum x | x == 0 = () - | otherwise = error "Prelude.Enum.().toEnum: bad argument" + | otherwise = errorWithoutStackTrace "Prelude.Enum.().toEnum: bad argument" fromEnum () = 0 enumFrom () = [()] @@ -266,14 +266,14 @@ instance Enum Bool where succ False = True - succ True = error "Prelude.Enum.Bool.succ: bad argument" + succ True = errorWithoutStackTrace "Prelude.Enum.Bool.succ: bad argument" pred True = False - pred False = error "Prelude.Enum.Bool.pred: bad argument" + pred False = errorWithoutStackTrace "Prelude.Enum.Bool.pred: bad argument" toEnum n | n == 0 = False | n == 1 = True - | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument" + | otherwise = errorWithoutStackTrace "Prelude.Enum.Bool.toEnum: bad argument" fromEnum False = 0 fromEnum True = 1 @@ -293,16 +293,16 @@ instance Enum Ordering where succ LT = EQ succ EQ = GT - succ GT = error "Prelude.Enum.Ordering.succ: bad argument" + succ GT = errorWithoutStackTrace "Prelude.Enum.Ordering.succ: bad argument" pred GT = EQ pred EQ = LT - pred LT = error "Prelude.Enum.Ordering.pred: bad argument" + pred LT = errorWithoutStackTrace "Prelude.Enum.Ordering.pred: bad argument" toEnum n | n == 0 = LT | n == 1 = EQ | n == 2 = GT - toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Prelude.Enum.Ordering.toEnum: bad argument" fromEnum LT = 0 fromEnum EQ = 1 @@ -323,10 +323,10 @@ instance Enum Char where succ (C# c#) | isTrue# (ord# c# /=# 0x10FFFF#) = C# (chr# (ord# c# +# 1#)) - | otherwise = error ("Prelude.Enum.Char.succ: bad argument") + | otherwise = errorWithoutStackTrace ("Prelude.Enum.Char.succ: bad argument") pred (C# c#) | isTrue# (ord# c# /=# 0#) = C# (chr# (ord# c# -# 1#)) - | otherwise = error ("Prelude.Enum.Char.pred: bad argument") + | otherwise = errorWithoutStackTrace ("Prelude.Enum.Char.pred: bad argument") toEnum = chr fromEnum = ord @@ -344,6 +344,7 @@ {-# INLINE enumFromThenTo #-} enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) +-- See Note [How the Enum rules work] {-# RULES "eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) "efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) @@ -448,10 +449,10 @@ instance Enum Int where succ x - | x == maxBound = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound" + | x == maxBound = errorWithoutStackTrace "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound" | otherwise = x + 1 pred x - | x == minBound = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound" + | x == minBound = errorWithoutStackTrace "Prelude.Enum.pred{Int}: tried to take `pred' of minBound" | otherwise = x - 1 toEnum x = x @@ -482,6 +483,13 @@ "eftIntList" [1] eftIntFB (:) [] = eftInt #-} +{- Note [How the Enum rules work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Phase 2: eftInt ---> build . eftIntFB +* Phase 1: inline build; eftIntFB (:) --> eftInt +* Phase 0: optionally inline eftInt +-} + {-# NOINLINE [1] eftInt #-} eftInt :: Int# -> Int# -> [Int] -- [x1..x2] @@ -510,6 +518,7 @@ -- efdInt and efdtInt deal with [a,b..] and [a,b..c]. -- The code is more complicated because of worries about Int overflow. +-- See Note [How the Enum rules work] {-# RULES "efdtInt" [~1] forall x1 x2 y. efdtInt x1 x2 y = build (\ c n -> efdtIntFB c n x1 x2 y) @@ -667,16 +676,36 @@ enumFromTo x lim = enumDeltaToInteger x 1 lim enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim +-- See Note [How the Enum rules work] {-# RULES -"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) -"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l) -"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger -"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger +"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) +"efdtInteger" [~1] forall x d l. enumDeltaToInteger x d l = build (\c n -> enumDeltaToIntegerFB c n x d l) +"efdtInteger1" [~1] forall x l. enumDeltaToInteger x 1 l = build (\c n -> enumDeltaToInteger1FB c n x l) + +"enumDeltaToInteger1FB" [1] forall c n x. enumDeltaToIntegerFB c n x 1 = enumDeltaToInteger1FB c n x + +"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger +"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger +"enumDeltaToInteger1" [1] enumDeltaToInteger1FB (:) [] = enumDeltaToInteger1 #-} +{- Note [Enum Integer rules for literal 1] +The "1" rules above specialise for the common case where delta = 1, +so that we can avoid the delta>=0 test in enumDeltaToIntegerFB. +Then enumDeltaToInteger1FB is nice and small and can be inlined, +which would allow the constructor to be inlined and good things to happen. + +We match on the literal "1" both in phase 2 (rule "efdtInteger1") and +phase 1 (rule "enumDeltaToInteger1FB"), just for belt and braces + +We do not do it for Int this way because hand-tuned code already exists, and +the special case varies more from the general case, due to the issue of overflows. +-} + {-# NOINLINE [0] enumDeltaIntegerFB #-} enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b -enumDeltaIntegerFB c x d = x `seq` (x `c` enumDeltaIntegerFB c (x+d) d) +enumDeltaIntegerFB c x0 d = go x0 + where go x = x `seq` (x `c` go (x+d)) {-# NOINLINE [1] enumDeltaInteger #-} enumDeltaInteger :: Integer -> Integer -> [Integer] @@ -693,20 +722,28 @@ | delta >= 0 = up_fb c n x delta lim | otherwise = dn_fb c n x delta lim -{-# RULES -"enumDeltaToInteger1" [0] forall c n x . enumDeltaToIntegerFB c n x 1 = up_fb c n x 1 - #-} --- This rule ensures that in the common case (delta = 1), we do not do the check here, --- and also that we have the chance to inline up_fb, which would allow the constructor to be --- inlined and good things to happen. --- We do not do it for Int this way because hand-tuned code already exists, and --- the special case varies more from the general case, due to the issue of overflows. +{-# NOINLINE [0] enumDeltaToInteger1FB #-} +-- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire +enumDeltaToInteger1FB :: (Integer -> a -> a) -> a + -> Integer -> Integer -> a +enumDeltaToInteger1FB c n x0 lim = go (x0 :: Integer) + where + go x | x > lim = n + | otherwise = x `c` go (x+1) {-# NOINLINE [1] enumDeltaToInteger #-} enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer] enumDeltaToInteger x delta lim | delta >= 0 = up_list x delta lim | otherwise = dn_list x delta lim + +{-# NOINLINE [1] enumDeltaToInteger1 #-} +enumDeltaToInteger1 :: Integer -> Integer -> [Integer] +-- Special case for Delta = 1 +enumDeltaToInteger1 x0 lim = go (x0 :: Integer) + where + go x | x > lim = [] + | otherwise = x : go (x+1) up_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a up_fb c n x0 delta lim = go (x0 :: Integer) diff --git a/GHC/Environment.hs b/GHC/Environment.hs --- a/GHC/Environment.hs +++ b/GHC/Environment.hs @@ -20,9 +20,18 @@ # else # error Unknown mingw32 arch # endif +#else +import GHC.IO.Encoding +import qualified GHC.Foreign as GHC +#endif --- Ignore the arguments to hs_init on Windows for the sake of Unicode compat +-- | Computation 'getFullArgs' is the "raw" version of 'getArgs', similar +-- to @argv@ in other languages. It returns a list of the program's +-- command line arguments, starting with the program name, and +-- including those normally eaten by the RTS (+RTS ... -RTS). getFullArgs :: IO [String] +#ifdef mingw32_HOST_OS +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat getFullArgs = do p_arg_string <- c_GetCommandLine alloca $ \p_argc -> do @@ -43,11 +52,6 @@ foreign import WINDOWS_CCONV unsafe "Windows.h LocalFree" c_LocalFree :: Ptr a -> IO (Ptr a) #else -import GHC.IO.Encoding -import GHC.Num -import qualified GHC.Foreign as GHC - -getFullArgs :: IO [String] getFullArgs = alloca $ \ p_argc -> alloca $ \ p_argv -> do @@ -55,7 +59,7 @@ p <- fromIntegral `liftM` peek p_argc argv <- peek p_argv enc <- getFileSystemEncoding - peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc) + peekArray p argv >>= mapM (GHC.peekCString enc) foreign import ccall unsafe "getFullProgArgv" getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () diff --git a/GHC/Err.hs b/GHC/Err.hs --- a/GHC/Err.hs +++ b/GHC/Err.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} +{-# LANGUAGE RankNTypes, TypeInType #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -21,27 +22,63 @@ -- ----------------------------------------------------------------------------- -module GHC.Err( absentErr, error, undefined ) where +module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.CString () -import GHC.Types +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 -- so the build system doesn't see the dependency -import {-# SOURCE #-} GHC.Exception( errorCallException ) +import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException ) -- | 'error' stops execution and displays an error message. -error :: [Char] -> a -error s = raise# (errorCallException s) +error :: forall (r :: RuntimeRep). forall (a :: TYPE r). + HasCallStack => [Char] -> a +error s = raise# (errorCallWithCallStackException s ?callStack) + -- Bleh, we should be using 'GHC.Stack.callStack' instead of + -- '?callStack' here, but 'GHC.Stack.callStack' depends on + -- 'GHC.Stack.popCallStack', which is partial and depends on + -- 'error'.. Do as I say, not as I do. +-- | A variant of 'error' that does not produce a stack trace. +-- +-- @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 + + +-- Note [Errors in base] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- As of base-4.9.0.0, `error` produces a stack trace alongside the +-- error message using the HasCallStack machinery. This provides +-- a partial stack trace, containing the call-site of each function +-- with a HasCallStack constraint. +-- +-- In base, however, the only functions that have such constraints are +-- error and undefined, so the stack traces from partial functions in +-- base will never contain a call-site in user code. Instead we'll +-- usually just get the actual call to error. Base functions already +-- have a good habit of providing detailed error messages, including the +-- name of the offending partial function, so the partial stack-trace +-- does not provide any extra information, just noise. Thus, we export +-- the callstack-aware error, but within base we use the +-- errorWithoutStackTrace variant for more hygienic error messages. + + -- | A special case of 'error'. -- It is expected that compilers will recognize this and insert error -- messages which are more appropriate to the context in which 'undefined' -- appears. -undefined :: a +undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). + HasCallStack => a undefined = error "Prelude.undefined" -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. absentErr :: a -absentErr = error "Oops! The program has entered an `absent' argument!\n" +absentErr = errorWithoutStackTrace "Oops! The program has entered an `absent' argument!\n" diff --git a/GHC/Event/Array.hs b/GHC/Event/Array.hs --- a/GHC/Event/Array.hs +++ b/GHC/Event/Array.hs @@ -45,7 +45,7 @@ -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! #define CHECK_BOUNDS(_func_,_len_,_k_) \ -if (_k_) < 0 || (_k_) >= (_len_) then error ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else +if (_k_) < 0 || (_k_) >= (_len_) then errorWithoutStackTrace ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else #else #define CHECK_BOUNDS(_func_,_len_,_k_) #endif @@ -132,7 +132,7 @@ withForeignPtr es $ \p -> pokeElemOff p ix a -unsafeLoad :: Storable a => Array a -> (Ptr a -> Int -> IO Int) -> IO Int +unsafeLoad :: Array a -> (Ptr a -> Int -> IO Int) -> IO Int unsafeLoad (Array ref) load = do AC es _ cap <- readIORef ref len' <- withForeignPtr es $ \p -> load p cap @@ -170,7 +170,7 @@ unsafeWrite' ac' len e writeIORef ref (AC es len' cap) -clear :: Storable a => Array a -> IO () +clear :: Array a -> IO () clear (Array ref) = do atomicModifyIORef' ref $ \(AC es _ cap) -> (AC es 0 cap, ()) @@ -247,7 +247,7 @@ copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b) copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 || - sstart > slen) $ error "copy: bad offsets or lengths" + sstart > slen) $ errorWithoutStackTrace "copy: bad offsets or lengths" let size = sizeOf dummy count = min maxCount (slen - sstart) if count == 0 @@ -267,7 +267,7 @@ removeHack :: Storable b => Array b -> b -> IO () removeHack (Array ary) dummy = do AC fp oldLen cap <- readIORef ary - when (i < 0 || i >= oldLen) $ error "removeAt: invalid index" + when (i < 0 || i >= oldLen) $ errorWithoutStackTrace "removeAt: invalid index" let size = sizeOf dummy newLen = oldLen - 1 when (newLen > 0 && i < newLen) . diff --git a/GHC/Event/Control.hs b/GHC/Event/Control.hs --- a/GHC/Event/Control.hs +++ b/GHC/Event/Control.hs @@ -159,7 +159,7 @@ r <- c_read (fromIntegral fd) (castPtr p_siginfo) sizeof_siginfo_t when (r /= fromIntegral sizeof_siginfo_t) $ - error "failed to read siginfo_t" + errorWithoutStackTrace "failed to read siginfo_t" let !s' = fromIntegral s return $ CMsgSignal fp s' @@ -195,7 +195,7 @@ case msg of CMsgWakeup -> poke p io_MANAGER_WAKEUP CMsgDie -> poke p io_MANAGER_DIE - CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" + CMsgSignal _fp _s -> errorWithoutStackTrace "Signals can only be sent from within the RTS" fromIntegral `fmap` c_write (fromIntegral fd) p 1 #if defined(HAVE_EVENTFD) diff --git a/GHC/Event/EPoll.hsc b/GHC/Event/EPoll.hsc --- a/GHC/Event/EPoll.hsc +++ b/GHC/Event/EPoll.hsc @@ -29,7 +29,7 @@ import GHC.Base new :: IO E.Backend -new = error "EPoll back end not implemented for this platform" +new = errorWithoutStackTrace "EPoll back end not implemented for this platform" available :: Bool available = False @@ -115,7 +115,7 @@ let events = epollEvents ep fd = epollFd ep - -- Will return zero if the system call was interupted, in which case + -- Will return zero if the system call was interrupted, in which case -- we just return (and try again later.) n <- A.unsafeLoad events $ \es cap -> case mtimeout of Just timeout -> epollWait fd es cap $ fromTimeout timeout diff --git a/GHC/Event/IntTable.hs b/GHC/Event/IntTable.hs --- a/GHC/Event/IntTable.hs +++ b/GHC/Event/IntTable.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, NoImplicitPrelude, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} module GHC.Event.IntTable ( @@ -15,10 +15,10 @@ import Data.Bits ((.&.), shiftL, shiftR) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Maybe (Maybe(..), isJust, isNothing) +import Data.Maybe (Maybe(..), isJust) import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr) import Foreign.Storable (peek, poke) -import GHC.Base (Monad(..), (=<<), ($), const, liftM, otherwise, when) +import GHC.Base (Monad(..), (=<<), ($), ($!), const, liftM, otherwise, when) import GHC.Classes (Eq(..), Ord(..)) import GHC.Event.Arr (Arr) import GHC.Num (Num(..)) @@ -47,11 +47,12 @@ lookup :: Int -> IntTable a -> IO (Maybe a) lookup k (IntTable ref) = do let go Bucket{..} - | bucketKey == k = return (Just bucketValue) + | bucketKey == k = Just bucketValue | otherwise = go bucketNext - go _ = return Nothing + go _ = Nothing it@IT{..} <- readIORef ref - go =<< Arr.read tabArr (indexOf k it) + bkt <- Arr.read tabArr (indexOf k it) + return $! go bkt new :: Int -> IO (IntTable a) new capacity = IntTable `liftM` (newIORef =<< new_ capacity) @@ -125,20 +126,18 @@ updateWith f k (IntTable ref) = do it@IT{..} <- readIORef ref let idx = indexOf k it - go changed bkt@Bucket{..} - | bucketKey == k = - let fbv = f bucketValue - !nb = case fbv of - Just val -> bkt { bucketValue = val } - Nothing -> bucketNext - in (fbv, Just bucketValue, nb) - | otherwise = case go changed bucketNext of + go bkt@Bucket{..} + | bucketKey == k = case f bucketValue of + Just val -> let !nb = bkt { bucketValue = val } + in (False, Just bucketValue, nb) + Nothing -> (True, Just bucketValue, bucketNext) + | otherwise = case go bucketNext of (fbv, ov, nb) -> (fbv, ov, bkt { bucketNext = nb }) - go _ e = (Nothing, Nothing, e) - (fbv, oldVal, newBucket) <- go False `liftM` Arr.read tabArr idx + go e = (False, Nothing, e) + (del, oldVal, newBucket) <- go `liftM` Arr.read tabArr idx when (isJust oldVal) $ do Arr.write tabArr idx newBucket - when (isNothing fbv) $ + when del $ withForeignPtr tabSize $ \ptr -> do size <- peek ptr poke ptr (size - 1) diff --git a/GHC/Event/KQueue.hsc b/GHC/Event/KQueue.hsc --- a/GHC/Event/KQueue.hsc +++ b/GHC/Event/KQueue.hsc @@ -19,7 +19,7 @@ import GHC.Base new :: IO E.Backend -new = error "KQueue back end not implemented for this platform" +new = errorWithoutStackTrace "KQueue back end not implemented for this platform" available :: Bool available = False @@ -274,7 +274,7 @@ toEvent (Filter f) | f == (#const EVFILT_READ) = E.evtRead | f == (#const EVFILT_WRITE) = E.evtWrite - | otherwise = error $ "toEvent: unknown filter " ++ show f + | otherwise = errorWithoutStackTrace $ "toEvent: unknown filter " ++ show f foreign import ccall unsafe "kqueue" c_kqueue :: IO CInt diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs --- a/GHC/Event/Manager.hs +++ b/GHC/Event/Manager.hs @@ -172,7 +172,7 @@ #elif defined(HAVE_POLL) newDefaultBackend = Poll.new #else -newDefaultBackend = error "no back end for this platform" +newDefaultBackend = errorWithoutStackTrace "no back end for this platform" #endif -- | Create a new event manager. @@ -212,7 +212,7 @@ when (not ok) $ let msg = "Failed while attempting to modify registration of file " ++ show fd ++ " at location " ++ loc - in error msg + in errorWithoutStackTrace msg registerControlFd :: EventManager -> Fd -> Event -> IO () registerControlFd mgr fd evs = @@ -267,7 +267,7 @@ -- in Thread.restartPollLoop. See #8235 Finished -> return () _ -> do cleanup mgr - error $ "GHC.Event.Manager.loop: state is already " ++ + errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++ show state where go = do state <- step mgr @@ -305,6 +305,11 @@ -- | Register interest in the given events, without waking the event -- manager thread. The 'Bool' return value indicates whether the -- event manager ought to be woken. +-- +-- Note that the event manager is generally implemented in terms of the +-- platform's @select@ or @epoll@ system call, which tend to vary in +-- what sort of fds are permitted. For instance, waiting on regular files +-- is not allowed on many platforms. registerFd_ :: EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO (FdKey, Bool) registerFd_ mgr@(EventManager{..}) cb fd evs lt = do diff --git a/GHC/Event/PSQ.hs b/GHC/Event/PSQ.hs --- a/GHC/Event/PSQ.hs +++ b/GHC/Event/PSQ.hs @@ -458,7 +458,7 @@ -- Utility functions moduleError :: String -> String -> a -moduleError fun msg = error ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg) +moduleError fun msg = errorWithoutStackTrace ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg) {-# NOINLINE moduleError #-} ------------------------------------------------------------------------ diff --git a/GHC/Event/Poll.hsc b/GHC/Event/Poll.hsc --- a/GHC/Event/Poll.hsc +++ b/GHC/Event/Poll.hsc @@ -17,7 +17,7 @@ import qualified GHC.Event.Internal as E new :: IO E.Backend -new = error "Poll back end not implemented for this platform" +new = errorWithoutStackTrace "Poll back end not implemented for this platform" available :: Bool available = False @@ -62,7 +62,7 @@ return True modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool -modifyFdOnce = error "modifyFdOnce not supported in Poll backend" +modifyFdOnce = errorWithoutStackTrace "modifyFdOnce not supported in Poll backend" reworkFd :: Poll -> PollFd -> IO () reworkFd p (PollFd fd npevt opevt) = do @@ -72,7 +72,7 @@ else do found <- A.findIndex ((== fd) . pfdFd) ary case found of - Nothing -> error "reworkFd: event not found" + Nothing -> errorWithoutStackTrace "reworkFd: event not found" Just (i,_) | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0 | otherwise -> A.removeAt ary i diff --git a/GHC/Event/TimerManager.hs b/GHC/Event/TimerManager.hs --- a/GHC/Event/TimerManager.hs +++ b/GHC/Event/TimerManager.hs @@ -108,7 +108,7 @@ #if defined(HAVE_POLL) newDefaultBackend = Poll.new #else -newDefaultBackend = error "no back end for this platform" +newDefaultBackend = errorWithoutStackTrace "no back end for this platform" #endif -- | Create a new event manager. @@ -168,7 +168,7 @@ Created -> go `finally` cleanup mgr Dying -> cleanup mgr _ -> do cleanup mgr - error $ "GHC.Event.Manager.loop: state is already " ++ + errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++ show state where go = do running <- step mgr diff --git a/GHC/Exception.hs b/GHC/Exception.hs --- a/GHC/Exception.hs +++ b/GHC/Exception.hs @@ -2,7 +2,8 @@ {-# LANGUAGE NoImplicitPrelude , ExistentialQuantification , MagicHash - , DeriveDataTypeable + , RecordWildCards + , PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} @@ -23,9 +24,13 @@ module GHC.Exception ( Exception(..) -- Class , throw - , SomeException(..), ErrorCall(..), ArithException(..) + , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) , divZeroException, overflowException, ratioZeroDenomException - , errorCallException + , errorCallException, errorCallWithCallStackException + -- re-export CallStack and SrcLoc from GHC.Types + , CallStack, fromCallSiteList, getCallStack, prettyCallStack + , prettyCallStackLines, showCCSStack + , SrcLoc(..), prettySrcLoc ) where import Data.Maybe @@ -33,6 +38,10 @@ -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show +import GHC.Stack.Types +import GHC.OldList +import GHC.IO.Unsafe +import {-# SOURCE #-} GHC.Stack.CCS {- | The @SomeException@ type is the root of the exception type hierarchy. @@ -40,7 +49,6 @@ encapsulated in a @SomeException@. -} data SomeException = forall e . Exception e => SomeException e - deriving Typeable instance Show SomeException where showsPrec p (SomeException e) = showsPrec p e @@ -160,17 +168,64 @@ -- |This is thrown when the user calls 'error'. The @String@ is the -- argument given to 'error'. -newtype ErrorCall = ErrorCall String - deriving (Eq, Ord, Typeable) +data ErrorCall = ErrorCallWithLocation String String + deriving (Eq, Ord) +pattern ErrorCall :: String -> ErrorCall +pattern ErrorCall err <- ErrorCallWithLocation err _ where + ErrorCall err = ErrorCallWithLocation err "" + instance Exception ErrorCall instance Show ErrorCall where - showsPrec _ (ErrorCall err) = showString err + showsPrec _ (ErrorCallWithLocation err "") = showString err + showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc) errorCallException :: String -> SomeException errorCallException s = toException (ErrorCall s) +errorCallWithCallStackException :: String -> CallStack -> SomeException +errorCallWithCallStackException s stk = unsafeDupablePerformIO $ do + ccsStack <- currentCallStack + let + implicitParamCallStack = prettyCallStackLines stk + ccsCallStack = showCCSStack ccsStack + stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack + return $ toException (ErrorCallWithLocation s stack) + +showCCSStack :: [String] -> [String] +showCCSStack [] = [] +showCCSStack stk = "CallStack (from -prof):" : map (" " ++) (reverse stk) + +-- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot +-- files. See Note [Definition of CallStack] + +-- | Pretty print a 'SrcLoc'. +-- +-- @since 4.9.0.0 +prettySrcLoc :: SrcLoc -> String +prettySrcLoc SrcLoc {..} + = foldr (++) "" + [ srcLocFile, ":" + , show srcLocStartLine, ":" + , show srcLocStartCol, " in " + , srcLocPackage, ":", srcLocModule + ] + +-- | Pretty print a 'CallStack'. +-- +-- @since 4.9.0.0 +prettyCallStack :: CallStack -> String +prettyCallStack = intercalate "\n" . prettyCallStackLines + +prettyCallStackLines :: CallStack -> [String] +prettyCallStackLines cs = case getCallStack cs of + [] -> [] + stk -> "CallStack (from HasCallStack):" + : map ((" " ++) . prettyCallSite) stk + where + prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc + -- |Arithmetic exceptions. data ArithException = Overflow @@ -179,7 +234,7 @@ | DivideByZero | Denormal | RatioZeroDenominator -- ^ @since 4.6.0.0 - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord) divZeroException, overflowException, ratioZeroDenomException :: SomeException divZeroException = toException DivideByZero diff --git a/GHC/Exception.hs-boot b/GHC/Exception.hs-boot --- a/GHC/Exception.hs-boot +++ b/GHC/Exception.hs-boot @@ -25,10 +25,14 @@ -} module GHC.Exception ( SomeException, errorCallException, + errorCallWithCallStackException, divZeroException, overflowException, ratioZeroDenomException ) where -import GHC.Types( Char ) +import GHC.Types ( Char ) +import GHC.Stack.Types ( CallStack ) data SomeException divZeroException, overflowException, ratioZeroDenomException :: SomeException + errorCallException :: [Char] -> SomeException +errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/GHC/ExecutionStack.hs b/GHC/ExecutionStack.hs new file mode 100644 --- /dev/null +++ b/GHC/ExecutionStack.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ExecutionStack +-- Copyright : (c) The University of Glasgow 2013-2015 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- This is a module for efficient stack traces. This stack trace implementation +-- is considered low overhead. Basic usage looks like this: +-- +-- @ +-- import GHC.ExecutionStack +-- +-- myFunction :: IO () +-- myFunction = do +-- putStrLn =<< showStackTrace +-- @ +-- +-- Your GHC must have been built with @libdw@ support for this to work. +-- +-- @ +-- user@host:~$ ghc --info | grep libdw +-- ,("RTS expects libdw","YES") +-- @ +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module GHC.ExecutionStack ( + Location (..) + , SrcLoc (..) + , getStackTrace + , showStackTrace + ) where + +import Control.Monad (join) +import GHC.ExecutionStack.Internal + +-- | Get a trace of the current execution stack state. +-- +-- Returns @Nothing@ if stack trace support isn't available on host machine. +getStackTrace :: IO (Maybe [Location]) +getStackTrace = (join . fmap stackFrames) `fmap` collectStackTrace + +-- | Get a string representation of the current execution stack state. +showStackTrace :: IO (Maybe String) +showStackTrace = fmap (\st -> showStackFrames st "") `fmap` getStackTrace diff --git a/GHC/ExecutionStack/Internal.hsc b/GHC/ExecutionStack/Internal.hsc new file mode 100644 --- /dev/null +++ b/GHC/ExecutionStack/Internal.hsc @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.ExecutionStack.Internal +-- Copyright : (c) The University of Glasgow 2013-2015 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Internals of the `GHC.ExecutionStack` module +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +#include "HsFFI.h" +#include "HsBaseConfig.h" +#include "rts/Libdw.h" + +{-# LANGUAGE MultiWayIf #-} + +module GHC.ExecutionStack.Internal ( + -- * Internal + Location (..) + , SrcLoc (..) + , StackTrace + , stackFrames + , stackDepth + , collectStackTrace + , showStackFrames + , invalidateDebugCache + ) where + +import Control.Monad (join) +import Data.Word +import Foreign.C.Types +import Foreign.C.String (peekCString, CString) +import Foreign.Ptr (Ptr, nullPtr, castPtr, plusPtr, FunPtr) +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Storable (Storable(..)) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) + +-- N.B. See includes/rts/Libdw.h for notes on stack representation. + +-- | A location in the original program source. +data SrcLoc = SrcLoc { sourceFile :: String + , sourceLine :: Int + , sourceColumn :: Int + } + +-- | Location information about an addresss from a backtrace. +data Location = Location { objectName :: String + , functionName :: String + , srcLoc :: Maybe SrcLoc + } + +-- | A chunk of backtrace frames +data Chunk = Chunk { chunkFrames :: !Word + , chunkNext :: !(Ptr Chunk) + , chunkFirstFrame :: !(Ptr Addr) + } + +-- | The state of the execution stack +newtype StackTrace = StackTrace (ForeignPtr StackTrace) + +-- | An address +type Addr = Ptr () + +withSession :: (ForeignPtr Session -> IO a) -> IO (Maybe a) +withSession action = do + ptr <- libdw_pool_take + if | nullPtr == ptr -> return Nothing + | otherwise -> do + fptr <- newForeignPtr libdw_pool_release ptr + ret <- action fptr + return $ Just ret + +-- | How many stack frames in the given 'StackTrace' +stackDepth :: StackTrace -> Int +stackDepth (StackTrace fptr) = + unsafePerformIO $ withForeignPtr fptr $ \ptr -> + fromIntegral . asWord <$> (#peek Backtrace,n_frames) ptr + where + asWord = id :: Word -> Word + +peekChunk :: Ptr Chunk -> IO Chunk +peekChunk ptr = + Chunk <$> (#peek BacktraceChunk,n_frames) ptr + <*> (#peek BacktraceChunk,next) ptr + <*> pure (castPtr $ (#ptr BacktraceChunk,frames) ptr) + +-- | Return a list of the chunks of a backtrace, from the outer-most to +-- inner-most chunk. +chunksList :: StackTrace -> IO [Chunk] +chunksList (StackTrace fptr) = withForeignPtr fptr $ \ptr -> + go [] =<< (#peek Backtrace,last) ptr + where + go accum ptr + | ptr == nullPtr = return accum + | otherwise = do + chunk <- peekChunk ptr + go (chunk : accum) (chunkNext chunk) + +-- | Unpack the given 'Location' in the Haskell representation +peekLocation :: Ptr Location -> IO Location +peekLocation ptr = do + let peekCStringPtr :: CString -> IO String + peekCStringPtr p + | p /= nullPtr = peekCString $ castPtr p + | otherwise = return "" + objFile <- peekCStringPtr =<< (#peek Location,object_file) ptr + function <- peekCStringPtr =<< (#peek Location,function) ptr + srcFile <- peekCStringPtr =<< (#peek Location,source_file) ptr + lineNo <- (#peek Location,lineno) ptr :: IO Word32 + colNo <- (#peek Location,colno) ptr :: IO Word32 + let _srcLoc + | null srcFile = Nothing + | otherwise = Just $ SrcLoc { sourceFile = srcFile + , sourceLine = fromIntegral lineNo + , sourceColumn = fromIntegral colNo + } + return Location { objectName = objFile + , functionName = function + , srcLoc = _srcLoc + } + +-- | The size in bytes of a 'locationSize' +locationSize :: Int +locationSize = (#const sizeof(Location)) + +-- | List the frames of a stack trace. +stackFrames :: StackTrace -> Maybe [Location] +stackFrames st@(StackTrace fptr) = unsafePerformIO $ withSession $ \sess -> do + chunks <- chunksList st + go sess (reverse chunks) + where + go :: ForeignPtr Session -> [Chunk] -> IO [Location] + go _ [] = return [] + go sess (chunk : chunks) = do + this <- iterChunk sess chunk + rest <- unsafeInterleaveIO (go sess chunks) + return (this ++ rest) + + {- + Here we lazily lookup the location information associated with each address + as this can be rather costly. This does mean, however, that if the set of + loaded modules changes between the time that we capture the stack and the + time we reach here, we may end up with nonsense (mostly likely merely + unknown symbols). I think this is a reasonable price to pay, however, as + module loading/unloading is a rather rare event. + + Morover, we stand to gain a great deal by lazy lookups as the stack frames + may never even be requested, meaning the only effort wasted is the + collection of the stack frames themselves. + + The only slightly tricky thing here is to ensure that the ForeignPtr + stays alive until we reach the end. + -} + iterChunk :: ForeignPtr Session -> Chunk -> IO [Location] + iterChunk sess chunk = iterFrames (chunkFrames chunk) (chunkFirstFrame chunk) + where + iterFrames :: Word -> Ptr Addr -> IO [Location] + iterFrames 0 _ = return [] + iterFrames n frame = do + pc <- peek frame :: IO Addr + mframe <- lookupFrame pc + rest <- unsafeInterleaveIO (iterFrames (n-1) frame') + return $ maybe rest (:rest) mframe + where + frame' = frame `plusPtr` sizeOf (undefined :: Addr) + + lookupFrame :: Addr -> IO (Maybe Location) + lookupFrame pc = withForeignPtr fptr $ const $ do + allocaBytes locationSize $ \buf -> do + ret <- withForeignPtr sess $ \sessPtr -> libdw_lookup_location sessPtr buf pc + case ret of + 0 -> Just <$> peekLocation buf + _ -> return Nothing + +-- | A LibdwSession from the runtime system +data Session + +foreign import ccall unsafe "libdwPoolTake" + libdw_pool_take :: IO (Ptr Session) + +foreign import ccall unsafe "&libdwPoolRelease" + libdw_pool_release :: FunPtr (Ptr Session -> IO ()) + +foreign import ccall unsafe "libdwPoolClear" + libdw_pool_clear :: IO () + +foreign import ccall unsafe "libdwLookupLocation" + libdw_lookup_location :: Ptr Session -> Ptr Location -> Addr -> IO CInt + +foreign import ccall unsafe "libdwGetBacktrace" + libdw_get_backtrace :: Ptr Session -> IO (Ptr StackTrace) + +foreign import ccall unsafe "&backtraceFree" + backtrace_free :: FunPtr (Ptr StackTrace -> IO ()) + +-- | Get an execution stack. +collectStackTrace :: IO (Maybe StackTrace) +collectStackTrace = fmap join $ withSession $ \sess -> do + st <- withForeignPtr sess libdw_get_backtrace + if | st == nullPtr -> return Nothing + | otherwise -> Just . StackTrace <$> newForeignPtr backtrace_free st + +-- | Free the cached debug data. +invalidateDebugCache :: IO () +invalidateDebugCache = libdw_pool_clear + +-- | Render a stacktrace as a string +showStackFrames :: [Location] -> ShowS +showStackFrames frames = + showString "Stack trace:\n" + . foldr (.) id (map showFrame frames) + where + showFrame loc = + showString " " . showLocation loc . showChar '\n' + +-- | Render a 'Location' as a string +showLocation :: Location -> ShowS +showLocation loc = + showString (functionName loc) + . maybe id showSrcLoc (srcLoc loc) + . showString " in " + . showString (objectName loc) + where + showSrcLoc :: SrcLoc -> ShowS + showSrcLoc sloc = + showString " (" + . showString (sourceFile sloc) + . showString ":" + . shows (sourceLine sloc) + . showString "." + . shows (sourceColumn sloc) + . showString ")" diff --git a/GHC/Exts.hs b/GHC/Exts.hs --- a/GHC/Exts.hs +++ b/GHC/Exts.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Unsafe #-} -{-# LANGUAGE MagicHash, UnboxedTuples, AutoDeriveTypeable, TypeFamilies, +{-# LANGUAGE MagicHash, UnboxedTuples, TypeFamilies, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, NoImplicitPrelude #-} ----------------------------------------------------------------------------- @@ -53,6 +53,12 @@ -- @since 4.7.0.0 Data.Coerce.coerce, Data.Coerce.Coercible, + -- * Equality + type (~~), + + -- * Representation polymorphism + GHC.Prim.TYPE, RuntimeRep(..), VecCount(..), VecElem(..), + -- * Transform comprehensions Down(..), groupWith, sortWith, the, @@ -72,8 +78,9 @@ IsList(..) ) where -import GHC.Prim hiding (coerce, Constraint) -import GHC.Base hiding (coerce) -- implicitly comes from GHC.Prim +import GHC.Prim hiding ( coerce, TYPE ) +import qualified GHC.Prim +import GHC.Base hiding ( coerce ) import GHC.Word import GHC.Int import GHC.Ptr @@ -96,8 +103,8 @@ the :: Eq a => [a] -> a the (x:xs) | all (x ==) xs = x - | otherwise = error "GHC.Exts.the: non-identical elements" -the [] = error "GHC.Exts.the: empty list" + | otherwise = errorWithoutStackTrace "GHC.Exts.the: non-identical elements" +the [] = errorWithoutStackTrace "GHC.Exts.the: empty list" -- | The 'sortWith' function sorts a list of elements using the -- user supplied function to project something out of each element @@ -140,7 +147,7 @@ -- entire ghc package at runtime data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr - deriving( Data, Typeable, Eq ) + deriving( Data, Eq ) {- ********************************************************************** @@ -184,3 +191,12 @@ type (Item Version) = Int fromList = makeVersion toList = versionBranch + +-- | Be aware that 'fromList . toList = id' only for unfrozen 'CallStack's, +-- since 'toList' removes frozenness information. +-- +-- @since 4.9.0.0 +instance IsList CallStack where + type (Item CallStack) = (String, SrcLoc) + fromList = fromCallSiteList + toList = getCallStack diff --git a/GHC/Fingerprint.hs b/GHC/Fingerprint.hs --- a/GHC/Fingerprint.hs +++ b/GHC/Fingerprint.hs @@ -95,7 +95,7 @@ let loop = do count <- hGetBuf h arrPtr _BUFSIZE eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ error $ + when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" f arrPtr count diff --git a/GHC/Float.hs b/GHC/Float.hs --- a/GHC/Float.hs +++ b/GHC/Float.hs @@ -4,9 +4,10 @@ , MagicHash , UnboxedTuples #-} +{-# LANGUAGE CApiFFI #-} -- We believe we could deorphan this module, by moving lots of things -- around, but we haven't got there yet: -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -26,10 +27,16 @@ #include "ieee-flpt.h" -module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# - , double2Int, int2Double, float2Int, int2Float ) - where +module GHC.Float + ( module GHC.Float + , Float(..), Double(..), Float#, Double# + , double2Int, int2Double, float2Int, int2Float + -- * Monomorphic equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + , eqFloat, eqDouble + ) where + import Data.Maybe import Data.Bits @@ -61,6 +68,46 @@ sinh, cosh, tanh :: a -> a asinh, acosh, atanh :: a -> a + -- | @'log1p' x@ computes @'log' (1 + x)@, but provides more precise + -- results for small (absolute) values of @x@ if possible. + -- + -- @since 4.9.0.0 + log1p :: a -> a + + -- | @'expm1' x@ computes @'exp' x - 1@, but provides more precise + -- results for small (absolute) values of @x@ if possible. + -- + -- @since 4.9.0.0 + expm1 :: a -> a + + -- | @'log1pexp' x@ computes @'log' (1 + 'exp' x)@, but provides more + -- precise results if possible. + -- + -- Examples: + -- + -- * if @x@ is a large negative number, @'log' (1 + 'exp' x)@ will be + -- imprecise for the reasons given in 'log1p'. + -- + -- * if @'exp' x@ is close to @-1@, @'log' (1 + 'exp' x)@ will be + -- imprecise for the reasons given in 'expm1'. + -- + -- @since 4.9.0.0 + log1pexp :: a -> a + + -- | @'log1mexp' x@ computes @'log' (1 - 'exp' x)@, but provides more + -- precise results if possible. + -- + -- Examples: + -- + -- * if @x@ is a large negative number, @'log' (1 - 'exp' x)@ will be + -- imprecise for the reasons given in 'log1p'. + -- + -- * if @'exp' x@ is close to @1@, @'log' (1 - 'exp' x)@ will be + -- imprecise for the reasons given in 'expm1'. + -- + -- @since 4.9.0.0 + log1mexp :: a -> a + {-# INLINE (**) #-} {-# INLINE logBase #-} {-# INLINE sqrt #-} @@ -72,6 +119,15 @@ tan x = sin x / cos x tanh x = sinh x / cosh x + {-# INLINE log1p #-} + {-# INLINE expm1 #-} + {-# INLINE log1pexp #-} + {-# INLINE log1mexp #-} + log1p x = log (1 + x) + expm1 x = exp x - 1 + log1pexp x = log1p (exp x) + log1mexp x = log1p (negate (exp x)) + -- | Efficient, machine-independent access to the components of a -- floating-point number. class (RealFrac a, Floating a) => RealFloat a where @@ -307,6 +363,19 @@ 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)) + log1p = log1pFloat + expm1 = expm1Float + + log1mexp a + | a <= log 2 = log (negate (expm1Float a)) + | otherwise = log1pFloat (negate (exp a)) + {-# INLINE log1mexp #-} + log1pexp a + | a <= 18 = log1pFloat (exp a) + | a <= 100 = a + exp (negate a) + | otherwise = a + {-# INLINE log1pexp #-} + instance RealFloat Float where floatRadix _ = FLT_RADIX -- from float.h floatDigits _ = FLT_MANT_DIG -- ditto @@ -415,6 +484,19 @@ 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)) + log1p = log1pDouble + expm1 = expm1Double + + log1mexp a + | a <= log 2 = log (negate (expm1Double a)) + | otherwise = log1pDouble (negate (exp a)) + {-# INLINE log1mexp #-} + log1pexp a + | a <= 18 = log1pDouble (exp a) + | a <= 100 = a + exp (negate a) + | otherwise = a + {-# INLINE log1pexp #-} + -- RULES for Integer and Int {-# RULES "properFraction/Double->Integer" properFraction = properFractionDoubleInteger @@ -582,7 +664,7 @@ "0" -> "0.0e0" [d] -> d : ".0e" ++ show_e' (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' - [] -> error "formatRealFloat/doFmt/FFExponent: []" + [] -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []" Just dec -> let dec' = max dec 1 in case is of @@ -628,7 +710,7 @@ case f d True is of x@(0,_) -> x (1,xs) -> (1, 1:xs) - _ -> error "roundTo: bad Value" + _ -> errorWithoutStackTrace "roundTo: bad Value" where b2 = base `quot` 2 @@ -983,11 +1065,9 @@ negateFloat :: Float -> Float negateFloat (F# x) = F# (negateFloat# x) -gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool +gtFloat, geFloat, ltFloat, leFloat :: Float -> Float -> Bool gtFloat (F# x) (F# y) = isTrue# (gtFloat# x y) geFloat (F# x) (F# y) = isTrue# (geFloat# x y) -eqFloat (F# x) (F# y) = isTrue# (eqFloat# x y) -neFloat (F# x) (F# y) = isTrue# (neFloat# x y) ltFloat (F# x) (F# y) = isTrue# (ltFloat# x y) leFloat (F# x) (F# y) = isTrue# (leFloat# x y) @@ -1023,11 +1103,9 @@ negateDouble :: Double -> Double negateDouble (D# x) = D# (negateDouble# x) -gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool +gtDouble, geDouble, leDouble, ltDouble :: Double -> Double -> Bool gtDouble (D# x) (D# y) = isTrue# (x >## y) geDouble (D# x) (D# y) = isTrue# (x >=## y) -eqDouble (D# x) (D# y) = isTrue# (x ==## y) -neDouble (D# x) (D# y) = isTrue# (x /=## y) ltDouble (D# x) (D# y) = isTrue# (x <## y) leDouble (D# x) (D# y) = isTrue# (x <=## y) @@ -1068,6 +1146,16 @@ foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int + + +------------------------------------------------------------------------ +-- libm imports for extended floating +------------------------------------------------------------------------ +foreign import capi unsafe "math.h log1p" log1pDouble :: Double -> Double +foreign import capi unsafe "math.h expm1" expm1Double :: Double -> Double +foreign import capi unsafe "math.h log1pf" log1pFloat :: Float -> Float +foreign import capi unsafe "math.h expm1f" expm1Float :: Float -> Float + ------------------------------------------------------------------------ -- Coercion rules diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs --- a/GHC/ForeignPtr.hs +++ b/GHC/ForeignPtr.hs @@ -5,7 +5,7 @@ , UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -46,7 +46,6 @@ import Foreign.Storable import Data.Foldable ( sequence_ ) -import Data.Typeable import GHC.Show import GHC.Base @@ -71,7 +70,6 @@ -- class 'Storable'. -- data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents - deriving Typeable -- we cache the Addr# in the ForeignPtr object, but attach -- the finalizer to the IORef (or the MutableByteArray# in -- the case of a MallocPtr). The aim of the representation @@ -155,7 +153,7 @@ mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a - | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0" | otherwise = do r <- newIORef NoFinalizers IO $ \s -> @@ -170,7 +168,7 @@ -- size of the memory required is given explicitly as a number of bytes. mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) mallocForeignPtrBytes size | size < 0 = - error "mallocForeignPtrBytes: size must be >= 0" + errorWithoutStackTrace "mallocForeignPtrBytes: size must be >= 0" mallocForeignPtrBytes (I# size) = do r <- newIORef NoFinalizers IO $ \s -> @@ -184,7 +182,7 @@ -- bytes. mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a) mallocForeignPtrAlignedBytes size _align | size < 0 = - error "mallocForeignPtrAlignedBytes: size must be >= 0" + errorWithoutStackTrace "mallocForeignPtrAlignedBytes: size must be >= 0" mallocForeignPtrAlignedBytes (I# size) (I# align) = do r <- newIORef NoFinalizers IO $ \s -> @@ -210,7 +208,7 @@ mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc a - | I# size < 0 = error "mallocForeignPtr: size must be >= 0" + | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0" | otherwise = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -225,7 +223,7 @@ -- exception to be thrown. mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a) mallocPlainForeignPtrBytes size | size < 0 = - error "mallocPlainForeignPtrBytes: size must be >= 0" + errorWithoutStackTrace "mallocPlainForeignPtrBytes: size must be >= 0" mallocPlainForeignPtrBytes (I# size) = IO $ \s -> case newPinnedByteArray# size s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -238,7 +236,7 @@ -- exception to be thrown. mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a) mallocPlainForeignPtrAlignedBytes size _align | size < 0 = - error "mallocPlainForeignPtrAlignedBytes: size must be >= 0" + errorWithoutStackTrace "mallocPlainForeignPtrAlignedBytes: size must be >= 0" mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) @@ -252,7 +250,7 @@ addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p () MallocPtr _ r -> insertCFinalizer r fp 0# nullAddr# p c - _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" -- Note [MallocPtr finalizers] (#10904) -- @@ -272,7 +270,7 @@ addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 1# ep p () MallocPtr _ r -> insertCFinalizer r fp 1# ep p c - _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- ^This function adds a finalizer to the given @ForeignPtr@. The @@ -298,19 +296,22 @@ if noFinalizers then IO $ \s -> case r of { IORef (STRef r#) -> - case mkWeak# r# () (foreignPtrFinalizer r) s of { (# s1, _ #) -> - (# s1, () #) }} + case mkWeak# r# () (unIO $ foreignPtrFinalizer r) s of { + (# s1, _ #) -> (# s1, () #) }} else return () addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do noFinalizers <- insertHaskellFinalizer r finalizer if noFinalizers then IO $ \s -> - case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of + case mkWeak# fo () finalizer' s of (# s1, _ #) -> (# s1, () #) else return () + where + finalizer' :: State# RealWorld -> (# State# RealWorld, () #) + finalizer' = unIO (foreignPtrFinalizer r >> touch f) addForeignPtrConcFinalizer_ _ _ = - error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer" + errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer" insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool insertHaskellFinalizer r f = do @@ -357,7 +358,7 @@ update _ _ = noMixingError noMixingError :: a -noMixingError = error $ +noMixingError = errorWithoutStackTrace $ "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++ "in the same ForeignPtr" @@ -440,5 +441,5 @@ (PlainForeignPtr ref) -> ref (MallocPtr _ ref) -> ref PlainPtr _ -> - error "finalizeForeignPtr PlainPtr" + errorWithoutStackTrace "finalizeForeignPtr PlainPtr" diff --git a/GHC/GHCi.hs b/GHC/GHCi.hs --- a/GHC/GHCi.hs +++ b/GHC/GHCi.hs @@ -21,7 +21,7 @@ GHCiSandboxIO(..), NoIO() ) where -import GHC.Base (IO(), Monad, Functor(fmap), Applicative(..), (>>=), return, id, (.), ap) +import GHC.Base (IO(), Monad, Functor(fmap), Applicative(..), (>>=), id, (.), ap) -- | A monad that can execute GHCi statements by lifting them out of -- m into the IO monad. (e.g state monads) @@ -38,11 +38,10 @@ 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/GHC/Generics.hs b/GHC/Generics.hs --- a/GHC/Generics.hs +++ b/GHC/Generics.hs @@ -1,17 +1,26 @@ -{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics --- Copyright : (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2013 +-- Copyright : (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2014 -- License : see libraries/base/LICENSE -- -- Maintainer : libraries@haskell.org @@ -29,7 +38,7 @@ -- -- | -- --- Datatype-generic functions are are based on the idea of converting values of +-- Datatype-generic functions are based on the idea of converting values of -- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. -- The type @'Rep' T@ is -- built from a limited set of type constructors, all provided by this module. A @@ -64,14 +73,26 @@ -- @ -- instance 'Generic' (Tree a) where -- type 'Rep' (Tree a) = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' ('Par0' a)) +-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False) +-- ('S1' '(MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' a)) -- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec0' (Tree a)) +-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' (Tree a)) -- ':*:' --- 'S1' 'NoSelector' ('Rec0' (Tree a)))) +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' (Tree a)))) -- ... -- @ -- @@ -79,11 +100,6 @@ -- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using -- the @:kind!@ command. -- -#if 0 --- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will --- use 'Rec0' everywhere. --- -#endif -- This is a lot of information! However, most of it is actually merely meta-information -- that makes names of datatypes and constructors and more available on the type level. -- @@ -93,7 +109,7 @@ -- @ -- instance 'Generic' (Tree a) where -- type 'Rep' (Tree a) = --- 'Par0' a +-- 'Rec0' a -- ':+:' -- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) -- @ @@ -102,7 +118,7 @@ -- is combined using the binary type constructor ':+:'. -- -- The first constructor consists of a single field, which is the parameter @a@. This is --- represented as @'Par0' a@. +-- represented as @'Rec0' a@. -- -- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, -- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using @@ -110,22 +126,43 @@ -- -- Now let us explain the additional tags being used in the complete representation: -- --- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with --- this field of the constructor. +-- * The @'S1' ('MetaSel 'Nothing 'NoSourceUnpackedness 'NoSourceStrictness +-- 'DecidedLazy)@ tag indicates several things. The @'Nothing@ indicates +-- that there is no record field selector associated with this field of +-- the constructor (if there were, it would have been marked @'Just +-- \"recordName\"@ instead). The other types contain meta-information on +-- the field's strictness: -- --- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is +-- * There is no @{\-\# UNPACK \#-\}@ or @{\-\# NOUNPACK \#-\}@ annotation +-- in the source, so it is tagged with @'NoSourceUnpackedness@. +-- +-- * There is no strictness (@!@) or laziness (@~@) annotation in the +-- source, so it is tagged with @'NoSourceStrictness@. +-- +-- * The compiler infers that the field is lazy, so it is tagged with +-- @'DecidedLazy@. Bear in mind that what the compiler decides may be +-- quite different from what is written in the source. See +-- 'DecidedStrictness' for a more detailed explanation. +-- +-- The @'MetaSel@ type is also an instance of the type class 'Selector', +-- which can be used to obtain information about the field at the value +-- level. +-- +-- * The @'C1' ('MetaCons \"Leaf\" 'PrefixI 'False)@ and +-- @'C1' ('MetaCons \"Node\" 'PrefixI 'False)@ invocations indicate that the enclosed part is -- the representation of the first and second constructor of datatype @Tree@, respectively. --- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of --- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful --- because they are instances of the type class 'Constructor'. This type class can be used --- to obtain information about the constructor in question, such as its name --- or infix priority. +-- Here, the meta-information regarding constructor names, fixity and whether +-- it has named fields or not is encoded at the type level. The @'MetaCons@ +-- type is also an instance of the type class 'Constructor'. This type class can be used +-- to obtain information about the constructor at the value level. -- --- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the --- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a --- proxy type, and is useful by being an instance of class 'Datatype', which --- can be used to obtain the name of a datatype, the module it has been defined in, and --- whether it has been defined using @data@ or @newtype@. +-- * The @'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)@ tag +-- indicates that the enclosed part is the representation of the +-- datatype @Tree@. Again, the meta-information is encoded at the type level. +-- The @'MetaData@ type is an instance of class 'Datatype', which +-- can be used to obtain the name of a datatype, the module it has been +-- defined in, the package it is located under, and whether it has been +-- defined using @data@ or @newtype@ at the value level. -- ** Derived and fundamental representation types -- @@ -142,14 +179,16 @@ -- -- | -- --- The type constructors 'Par0' and 'Rec0' are variants of 'K1': +-- The type constructor 'Rec0' is a variant of 'K1': -- -- @ --- type 'Par0' = 'K1' 'P' -- type 'Rec0' = 'K1' 'R' -- @ -- --- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. +-- Here, 'R' is a type-level proxy that does not have any associated values. +-- +-- There used to be another variant of 'K1' (namely 'Par0'), but it has since +-- been deprecated. -- *** Meta information: 'M1' -- @@ -187,7 +226,8 @@ -- -- @ -- instance 'Generic' Empty where --- type 'Rep' Empty = 'D1' D1Empty 'V1' +-- type 'Rep' Empty = +-- 'D1' ('MetaData \"Empty\" \"Main\" \"package-name\" 'False) 'V1' -- @ -- **** Constructors without fields: 'U1' @@ -200,8 +240,8 @@ -- @ -- instance 'Generic' Bool where -- type 'Rep' Bool = --- 'D1' D1Bool --- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') +-- 'D1' ('MetaData \"Bool\" \"Data.Bool\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"False\" 'PrefixI 'False) 'U1' ':+:' 'C1' ('MetaCons \"True\" 'PrefixI 'False) 'U1') -- @ -- *** Representation of types with many constructors or many fields @@ -347,7 +387,7 @@ -- @ -- class Encode a where -- encode :: a -> [Bool] --- default encode :: ('Generic' a) => a -> [Bool] +-- default encode :: (Generic a, Encode' (Rep a)) => a -> [Bool] -- encode x = encode' ('from' x) -- @ -- @@ -448,17 +488,31 @@ -- -- The above declaration causes the following representation to be generated: -- +-- @ -- instance 'Generic1' Tree where -- type 'Rep1' Tree = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' 'Par1') +-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'Par1') -- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec1' Tree) +-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec1' Tree) -- ':*:' --- 'S1' 'NoSelector' ('Rec1' Tree))) +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec1' Tree))) -- ... +-- @ -- -- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well -- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we @@ -474,7 +528,7 @@ -- -- | -- --- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not +-- Unlike 'Rec0', the 'Par1' and 'Rec1' type constructors do not -- map to 'K1'. They are defined directly, as follows: -- -- @ @@ -500,11 +554,19 @@ -- @ -- class 'Rep1' WithInt where -- type 'Rep1' WithInt = --- 'D1' D1WithInt --- ('C1' C1_0WithInt --- ('S1' 'NoSelector' ('Rec0' Int) +-- 'D1' ('MetaData \"WithInt\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ('Rec0' Int) -- ':*:' --- 'S1' 'NoSelector' 'Par1')) +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'Par1')) -- @ -- -- If the parameter @a@ appears underneath a composition of other type constructors, @@ -519,11 +581,19 @@ -- @ -- class 'Rep1' Rose where -- type 'Rep1' Rose = --- 'D1' D1Rose --- ('C1' C1_0Rose --- ('S1' 'NoSelector' 'Par1' +-- 'D1' ('MetaData \"Rose\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"Fork\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- 'Par1' -- ':*:' --- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) +-- 'S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- ([] ':.:' 'Rec1' Rose))) -- @ -- -- where @@ -531,6 +601,69 @@ -- @ -- 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' ('MetaData \"IntHash\" \"Main\" \"package-name\" 'False) +-- ('C1' ('MetaCons \"IntHash\" 'PrefixI 'False) +-- ('S1' ('MetaSel 'Nothing +-- 'NoSourceUnpackedness +-- 'NoSourceStrictness +-- 'DecidedLazy) +-- '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 -- @@ -547,13 +680,20 @@ 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 + , Rec0, R , D1, C1, S1, D, C, S -- * Meta-information - , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec + , Datatype(..), Constructor(..), Selector(..) + , Fixity(..), FixityI(..), Associativity(..), prec + , SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..) + , Meta(..) -- * Generic type classes , Generic(..), Generic1(..) @@ -561,69 +701,204 @@ ) where -- We use some base types +import Data.Either ( Either (..) ) +import Data.Maybe ( Maybe(..), fromMaybe ) +import GHC.Integer ( Integer, integerToInt ) +import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) +import GHC.Ptr ( Ptr ) import GHC.Types -import Data.Maybe ( Maybe(..) ) -import Data.Either ( Either(..) ) -- Needed for instances -import GHC.Classes ( Eq, Ord ) -import GHC.Read ( Read ) -import GHC.Show ( Show ) -import Data.Proxy +import GHC.Arr ( Ix ) +import GHC.Base ( Alternative(..), Applicative(..), Functor(..) + , Monad(..), MonadPlus(..), String ) +import GHC.Classes ( Eq(..), Ord(..) ) +import GHC.Enum ( Bounded, Enum ) +import GHC.Read ( Read(..), lex, readParen ) +import GHC.Show ( Show(..), showString ) +-- Needed for metadata +import Data.Proxy ( Proxy(..), KProxy(..) ) +import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal ) + -------------------------------------------------------------------------------- -- Representation types -------------------------------------------------------------------------------- -- | Void: used for datatypes without constructors -data V1 p +data V1 (p :: *) + deriving (Functor, Generic, Generic1) +deriving instance Eq (V1 p) +deriving instance Ord (V1 p) +deriving instance Read (V1 p) +deriving instance Show (V1 p) + -- | Unit: used for constructors without arguments -data U1 p = U1 - deriving (Eq, Ord, Read, Show, Generic) +data U1 (p :: *) = U1 + deriving (Generic, Generic1) +instance Eq (U1 p) where + _ == _ = True + +instance Ord (U1 p) where + compare _ _ = EQ + +instance Read (U1 p) where + readsPrec d = readParen (d > 10) (\r -> [(U1, s) | ("U1",s) <- lex r ]) + +instance Show (U1 p) where + showsPrec _ _ = showString "U1" + +instance Functor U1 where + fmap _ _ = U1 + +instance Applicative U1 where + pure _ = U1 + _ <*> _ = U1 + +instance Alternative U1 where + empty = U1 + _ <|> _ = U1 + +instance Monad U1 where + _ >>= _ = U1 + +instance MonadPlus U1 + -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +instance Applicative Par1 where + pure a = Par1 a + Par1 f <*> Par1 x = Par1 (f x) + +instance Monad Par1 where + Par1 x >>= f = f x + -- | Recursive calls of kind * -> * -newtype Rec1 f p = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show, Generic) +newtype Rec1 f (p :: *) = Rec1 { unRec1 :: f p } + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +instance Applicative f => Applicative (Rec1 f) where + pure a = Rec1 (pure a) + Rec1 f <*> Rec1 x = Rec1 (f <*> x) + +instance Alternative f => Alternative (Rec1 f) where + empty = Rec1 empty + Rec1 l <|> Rec1 r = Rec1 (l <|> r) + +instance Monad f => Monad (Rec1 f) where + Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a)) + +instance MonadPlus f => MonadPlus (Rec1 f) + -- | Constants, additional parameters and recursion of kind * -newtype K1 i c p = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show, Generic) +newtype K1 (i :: *) c (p :: *) = K1 { unK1 :: c } + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +instance Applicative f => Applicative (M1 i c f) where + pure a = M1 (pure a) + M1 f <*> M1 x = M1 (f <*> x) + +instance Alternative f => Alternative (M1 i c f) where + empty = M1 empty + M1 l <|> M1 r = M1 (l <|> r) + +instance Monad f => Monad (M1 i c f) where + M1 x >>= f = M1 (x >>= \a -> unM1 (f a)) + +instance MonadPlus f => MonadPlus (M1 i c f) + -- | Meta-information (constructor names, etc.) -newtype M1 i c f p = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show, Generic) +newtype M1 (i :: *) (c :: Meta) f (p :: *) = M1 { unM1 :: f p } + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) -- | Sums: encode choice between constructors infixr 5 :+: -data (:+:) f g p = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show, Generic) +data (:+:) f g (p :: *) = L1 (f p) | R1 (g p) + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) -- | Products: encode multiple arguments to constructors infixr 6 :*: -data (:*:) f g p = f p :*: g p - deriving (Eq, Ord, Read, Show, Generic) +data (:*:) f g (p :: *) = f p :*: g p + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +instance (Applicative f, Applicative g) => Applicative (f :*: g) where + pure a = pure a :*: pure a + (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y) + +instance (Alternative f, Alternative g) => Alternative (f :*: g) where + empty = empty :*: empty + (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2) + +instance (Monad f, Monad g) => Monad (f :*: g) where + (m :*: n) >>= f = (m >>= \a -> fstP (f a)) :*: (n >>= \a -> sndP (f a)) + where + fstP (a :*: _) = a + sndP (_ :*: b) = b + +instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) + -- | Composition of functors infixr 7 :.: -newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show, Generic) +newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) } + deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1) +instance (Applicative f, Applicative g) => Applicative (f :.: g) where + pure x = Comp1 (pure (pure x)) + Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x) + +instance (Alternative f, Applicative g) => Alternative (f :.: g) where + empty = Comp1 empty + Comp1 x <|> Comp1 y = Comp1 (x <|> y) + +-- | 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, Functor, Generic, Generic1) + +-- | Used for marking occurrences of 'Char#' +data instance URec Char p = UChar { uChar# :: Char# } + deriving (Eq, Ord, Show, Functor, Generic, Generic1) + +-- | Used for marking occurrences of 'Double#' +data instance URec Double p = UDouble { uDouble# :: Double# } + deriving (Eq, Ord, Show, Functor, Generic, Generic1) + +-- | Used for marking occurrences of 'Float#' +data instance URec Float p = UFloat { uFloat# :: Float# } + deriving (Eq, Ord, Show, Functor, Generic, Generic1) + +-- | Used for marking occurrences of 'Int#' +data instance URec Int p = UInt { uInt# :: Int# } + deriving (Eq, Ord, Show, Functor, Generic, Generic1) + +-- | Used for marking occurrences of 'Word#' +data instance URec Word p = UWord { uWord# :: Word# } + deriving (Eq, Ord, Show, Functor, Generic, Generic1) + +-- | 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) -data P -- | Type synonym for encoding recursion (of kind *) type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P -{-# DEPRECATED Par0 "'Par0' is no longer used; use 'Rec0' instead" #-} -- deprecated in 7.6 -{-# DEPRECATED P "'P' is no longer used; use 'R' instead" #-} -- deprecated in 7.6 -- | Tag for M1: datatype data D @@ -641,27 +916,24 @@ -- | 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) datatypeName :: t d (f :: * -> *) a -> [Char] -- | The fully-qualified name of the module where the type is declared moduleName :: t d (f :: * -> *) a -> [Char] + -- | The package name of the module where the type is declared + packageName :: t d (f :: * -> *) a -> [Char] -- | Marks if the datatype is actually a newtype isNewtype :: t d (f :: * -> *) a -> Bool isNewtype _ = False - --- | Class for datatypes that represent records -class Selector s where - -- | The name of the selector - selName :: t s (f :: * -> *) a -> [Char] - --- | Used for constructor fields without a name -data NoSelector - -instance Selector NoSelector where selName _ = "" +instance (KnownSymbol n, KnownSymbol m, KnownSymbol p, SingI nt) + => Datatype ('MetaData n m p nt) where + datatypeName _ = symbolVal (Proxy :: Proxy n) + moduleName _ = symbolVal (Proxy :: Proxy m) + packageName _ = symbolVal (Proxy :: Proxy p) + isNewtype _ = fromSing (sing :: Sing nt) -- | Class for datatypes that represent data constructors class Constructor c where @@ -676,16 +948,20 @@ conIsRecord :: t c (f :: * -> *) a -> Bool conIsRecord _ = False - --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read, Generic) +instance (KnownSymbol n, SingI f, SingI r) + => Constructor ('MetaCons n f r) where + conName _ = symbolVal (Proxy :: Proxy n) + conFixity _ = fromSing (sing :: Sing f) + conIsRecord _ = fromSing (sing :: Sing r) -- | 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) +-- | This variant of 'Fixity' appears at the type level. +data FixityI = PrefixI | InfixI Associativity Nat + -- | Get the precedence of a fixity value. prec :: Fixity -> Int prec Prefix = 10 @@ -695,8 +971,81 @@ data Associativity = LeftAssociative | RightAssociative | NotAssociative - deriving (Eq, Show, Ord, Read, Generic) + deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) +-- | The unpackedness of a field as the user wrote it in the source code. For +-- example, in the following data type: +-- +-- @ +-- data E = ExampleConstructor Int +-- {\-\# NOUNPACK \#-\} Int +-- {\-\# UNPACK \#-\} Int +-- @ +-- +-- The fields of @ExampleConstructor@ have 'NoSourceUnpackedness', +-- 'SourceNoUnpack', and 'SourceUnpack', respectively. +data SourceUnpackedness = NoSourceUnpackedness + | SourceNoUnpack + | SourceUnpack + deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + +-- | The strictness of a field as the user wrote it in the source code. For +-- example, in the following data type: +-- +-- @ +-- data E = ExampleConstructor Int ~Int !Int +-- @ +-- +-- The fields of @ExampleConstructor@ have 'NoSourceStrictness', +-- 'SourceLazy', and 'SourceStrict', respectively. +data SourceStrictness = NoSourceStrictness + | SourceLazy + | SourceStrict + deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + +-- | The strictness that GHC infers for a field during compilation. Whereas +-- there are nine different combinations of 'SourceUnpackedness' and +-- 'SourceStrictness', the strictness that GHC decides will ultimately be one +-- of lazy, strict, or unpacked. What GHC decides is affected both by what the +-- user writes in the source code and by GHC flags. As an example, consider +-- this data type: +-- +-- @ +-- data E = ExampleConstructor {\-\# UNPACK \#-\} !Int !Int Int +-- @ +-- +-- * If compiled without optimization or other language extensions, then the +-- fields of @ExampleConstructor@ will have 'DecidedStrict', 'DecidedStrict', +-- and 'DecidedLazy', respectively. +-- +-- * If compiled with @-XStrictData@ enabled, then the fields will have +-- 'DecidedStrict', 'DecidedStrict', and 'DecidedStrict', respectively. +-- +-- * If compiled with @-O2@ enabled, then the fields will have 'DecidedUnpack', +-- 'DecidedStrict', and 'DecidedLazy', respectively. +data DecidedStrictness = DecidedLazy + | DecidedStrict + | DecidedUnpack + deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic) + +-- | Class for datatypes that represent records +class Selector s where + -- | The name of the selector + selName :: t s (f :: * -> *) a -> [Char] + -- | The selector's unpackedness annotation (if any) + selSourceUnpackedness :: t s (f :: * -> *) a -> SourceUnpackedness + -- | The selector's strictness annotation (if any) + selSourceStrictness :: t s (f :: * -> *) a -> SourceStrictness + -- | The strictness that the compiler inferred for the selector + selDecidedStrictness :: t s (f :: * -> *) a -> DecidedStrictness + +instance (SingI mn, SingI su, SingI ss, SingI ds) + => Selector ('MetaSel mn su ss ds) where + selName _ = fromMaybe "" (fromSing (sing :: Sing mn)) + selSourceUnpackedness _ = fromSing (sing :: Sing su) + selSourceStrictness _ = fromSing (sing :: Sing ss) + selDecidedStrictness _ = fromSing (sing :: Sing ds) + -- | Representable types of kind *. -- This class is derivable in GHC with the DeriveGeneric flag on. class Generic a where @@ -718,15 +1067,39 @@ -- | Convert from the representation to the datatype to1 :: (Rep1 f) a -> f a +-------------------------------------------------------------------------------- +-- Meta-data +-------------------------------------------------------------------------------- +-- | Datatype to represent metadata associated with a datatype (@MetaData@), +-- constructor (@MetaCons@), or field selector (@MetaSel@). +-- +-- * In @MetaData n m p nt@, @n@ is the datatype's name, @m@ is the module in +-- which the datatype is defined, @p@ is the package in which the datatype +-- is defined, and @nt@ is @'True@ if the datatype is a @newtype@. +-- +-- * In @MetaCons n f s@, @n@ is the constructor's name, @f@ is its fixity, +-- and @s@ is @'True@ if the constructor contains record selectors. +-- +-- * In @MetaSel mn su ss ds@, if the field is uses record syntax, then @mn@ is +-- 'Just' the record name. Otherwise, @mn@ is 'Nothing. @su@ and @ss@ are the +-- field's unpackedness and strictness annotations, and @ds@ is the +-- strictness that GHC infers for the field. +data Meta = MetaData Symbol Symbol Symbol Bool + | MetaCons Symbol FixityI Bool + | MetaSel (Maybe Symbol) + SourceUnpackedness SourceStrictness DecidedStrictness + -------------------------------------------------------------------------------- -- Derived instances -------------------------------------------------------------------------------- + deriving instance Generic [a] deriving instance Generic (Maybe a) deriving instance Generic (Either a b) deriving instance Generic Bool deriving instance Generic Ordering +deriving instance Generic (Proxy t) deriving instance Generic () deriving instance Generic ((,) a b) deriving instance Generic ((,,) a b c) @@ -738,6 +1111,7 @@ deriving instance Generic1 [] deriving instance Generic1 Maybe deriving instance Generic1 (Either a) +deriving instance Generic1 Proxy deriving instance Generic1 ((,) a) deriving instance Generic1 ((,,) a b) deriving instance Generic1 ((,,,) a b c) @@ -746,74 +1120,143 @@ deriving instance Generic1 ((,,,,,,) a b c d e f) -------------------------------------------------------------------------------- --- Primitive representations +-- Copied from the singletons package -------------------------------------------------------------------------------- --- Int -data D_Int -data C_Int +-- | The singleton kind-indexed data family. +data family Sing (a :: k) -instance Datatype D_Int where - datatypeName _ = "Int" - moduleName _ = "GHC.Int" +-- | A 'SingI' constraint is essentially an implicitly-passed singleton. +-- If you need to satisfy this constraint with an explicit singleton, please +-- see 'withSingI'. +class SingI (a :: k) where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a -instance Constructor C_Int where - conName _ = "" -- JPM: I'm not sure this is the right implementation... +-- | The 'SingKind' class is essentially a /kind/ class. It classifies all kinds +-- for which singletons are defined. The class supports converting between a singleton +-- type and the base (unrefined) type which it is built from. +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + -- | Get a base type from a proxy for the promoted kind. For example, + -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. + type DemoteRep kparam :: * -instance Generic Int where - type Rep Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> DemoteRep kparam +-- Singleton symbols +data instance Sing (s :: Symbol) where + SSym :: KnownSymbol s => Sing s --- Float -data D_Float -data C_Float +instance KnownSymbol a => SingI a where sing = SSym -instance Datatype D_Float where - datatypeName _ = "Float" - moduleName _ = "GHC.Float" +instance SingKind ('KProxy :: KProxy Symbol) where + type DemoteRep ('KProxy :: KProxy Symbol) = String + fromSing (SSym :: Sing s) = symbolVal (Proxy :: Proxy s) -instance Constructor C_Float where - conName _ = "" -- JPM: I'm not sure this is the right implementation... +-- Singleton booleans +data instance Sing (a :: Bool) where + STrue :: Sing 'True + SFalse :: Sing 'False -instance Generic Float where - type Rep Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x +instance SingI 'True where sing = STrue +instance SingI 'False where sing = SFalse +instance SingKind ('KProxy :: KProxy Bool) where + type DemoteRep ('KProxy :: KProxy Bool) = Bool + fromSing STrue = True + fromSing SFalse = False --- Double -data D_Double -data C_Double +-- Singleton Maybe +data instance Sing (b :: Maybe a) where + SNothing :: Sing 'Nothing + SJust :: Sing a -> Sing ('Just a) -instance Datatype D_Double where - datatypeName _ = "Double" - moduleName _ = "GHC.Float" +instance SingI 'Nothing where sing = SNothing +instance SingI a => SingI ('Just a) where sing = SJust sing -instance Constructor C_Double where - conName _ = "" -- JPM: I'm not sure this is the right implementation... +instance SingKind ('KProxy :: KProxy a) => + SingKind ('KProxy :: KProxy (Maybe a)) where + type DemoteRep ('KProxy :: KProxy (Maybe a)) = + Maybe (DemoteRep ('KProxy :: KProxy a)) + fromSing SNothing = Nothing + fromSing (SJust a) = Just (fromSing a) -instance Generic Double where - type Rep Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x +-- Singleton Fixity +data instance Sing (a :: FixityI) where + SPrefix :: Sing 'PrefixI + SInfix :: Sing a -> Integer -> Sing ('InfixI a n) +instance SingI 'PrefixI where sing = SPrefix +instance (SingI a, KnownNat n) => SingI ('InfixI a n) where + sing = SInfix (sing :: Sing a) (natVal (Proxy :: Proxy n)) --- Char -data D_Char -data C_Char +instance SingKind ('KProxy :: KProxy FixityI) where + type DemoteRep ('KProxy :: KProxy FixityI) = Fixity + fromSing SPrefix = Prefix + fromSing (SInfix a n) = Infix (fromSing a) (I# (integerToInt n)) -instance Datatype D_Char where - datatypeName _ = "Char" - moduleName _ = "GHC.Base" +-- Singleton Associativity +data instance Sing (a :: Associativity) where + SLeftAssociative :: Sing 'LeftAssociative + SRightAssociative :: Sing 'RightAssociative + SNotAssociative :: Sing 'NotAssociative -instance Constructor C_Char where - conName _ = "" -- JPM: I'm not sure this is the right implementation... +instance SingI 'LeftAssociative where sing = SLeftAssociative +instance SingI 'RightAssociative where sing = SRightAssociative +instance SingI 'NotAssociative where sing = SNotAssociative -instance Generic Char where - type Rep Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x +instance SingKind ('KProxy :: KProxy Associativity) where + type DemoteRep ('KProxy :: KProxy Associativity) = Associativity + fromSing SLeftAssociative = LeftAssociative + fromSing SRightAssociative = RightAssociative + fromSing SNotAssociative = NotAssociative -deriving instance Generic (Proxy t) +-- Singleton SourceUnpackedness +data instance Sing (a :: SourceUnpackedness) where + SNoSourceUnpackedness :: Sing 'NoSourceUnpackedness + SSourceNoUnpack :: Sing 'SourceNoUnpack + SSourceUnpack :: Sing 'SourceUnpack + +instance SingI 'NoSourceUnpackedness where sing = SNoSourceUnpackedness +instance SingI 'SourceNoUnpack where sing = SSourceNoUnpack +instance SingI 'SourceUnpack where sing = SSourceUnpack + +instance SingKind ('KProxy :: KProxy SourceUnpackedness) where + type DemoteRep ('KProxy :: KProxy SourceUnpackedness) = SourceUnpackedness + fromSing SNoSourceUnpackedness = NoSourceUnpackedness + fromSing SSourceNoUnpack = SourceNoUnpack + fromSing SSourceUnpack = SourceUnpack + +-- Singleton SourceStrictness +data instance Sing (a :: SourceStrictness) where + SNoSourceStrictness :: Sing 'NoSourceStrictness + SSourceLazy :: Sing 'SourceLazy + SSourceStrict :: Sing 'SourceStrict + +instance SingI 'NoSourceStrictness where sing = SNoSourceStrictness +instance SingI 'SourceLazy where sing = SSourceLazy +instance SingI 'SourceStrict where sing = SSourceStrict + +instance SingKind ('KProxy :: KProxy SourceStrictness) where + type DemoteRep ('KProxy :: KProxy SourceStrictness) = SourceStrictness + fromSing SNoSourceStrictness = NoSourceStrictness + fromSing SSourceLazy = SourceLazy + fromSing SSourceStrict = SourceStrict + +-- Singleton DecidedStrictness +data instance Sing (a :: DecidedStrictness) where + SDecidedLazy :: Sing 'DecidedLazy + SDecidedStrict :: Sing 'DecidedStrict + SDecidedUnpack :: Sing 'DecidedUnpack + +instance SingI 'DecidedLazy where sing = SDecidedLazy +instance SingI 'DecidedStrict where sing = SDecidedStrict +instance SingI 'DecidedUnpack where sing = SDecidedUnpack + +instance SingKind ('KProxy :: KProxy DecidedStrictness) where + type DemoteRep ('KProxy :: KProxy DecidedStrictness) = DecidedStrictness + fromSing SDecidedLazy = DecidedLazy + fromSing SDecidedStrict = DecidedStrict + fromSing SDecidedUnpack = DecidedUnpack diff --git a/GHC/IO.hs b/GHC/IO.hs --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -23,7 +23,7 @@ ----------------------------------------------------------------------------- module GHC.IO ( - IO(..), unIO, failIO, liftIO, + IO(..), unIO, failIO, liftIO, mplusIO, unsafePerformIO, unsafeInterleaveIO, unsafeDupablePerformIO, unsafeDupableInterleaveIO, noDuplicate, @@ -36,7 +36,7 @@ catchException, catchAny, throwIO, mask, mask_, uninterruptibleMask, uninterruptibleMask_, MaskingState(..), getMaskingState, - unsafeUnmask, + unsafeUnmask, interruptible, onException, bracket, finally, evaluate ) where @@ -44,8 +44,9 @@ import GHC.ST import GHC.Exception import GHC.Show +import GHC.IO.Unsafe -import {-# SOURCE #-} GHC.IO.Exception ( userError ) +import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError ) -- --------------------------------------------------------------------------- -- The IO Monad @@ -101,163 +102,6 @@ unsafeSTToIO :: ST s a -> IO a unsafeSTToIO (ST m) = IO (unsafeCoerce# m) --- --------------------------------------------------------------------------- --- Unsafe IO operations - -{-| -This is the \"back door\" into the 'IO' monad, allowing -'IO' computation to be performed at any time. For -this to be safe, the 'IO' computation should be -free of side effects and independent of its environment. - -If the I\/O computation wrapped in 'unsafePerformIO' performs side -effects, then the relative order in which those side effects take -place (relative to the main I\/O trunk, or other calls to -'unsafePerformIO') is indeterminate. Furthermore, when using -'unsafePerformIO' to cause side-effects, you should take the following -precautions to ensure the side effects are performed as many times as -you expect them to be. Note that these precautions are necessary for -GHC, but may not be sufficient, and other compilers may require -different precautions: - - * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ - that calls 'unsafePerformIO'. If the call is inlined, - the I\/O may be performed more than once. - - * Use the compiler flag @-fno-cse@ to prevent common sub-expression - elimination being performed on the module, which might combine - two side effects that were meant to be separate. A good example - is using multiple global variables (like @test@ in the example below). - - * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the - call to 'unsafePerformIO' cannot float outside a lambda. For example, - if you say: - @ - f x = unsafePerformIO (newIORef []) - @ - you may get only one reference cell shared between all calls to @f@. - Better would be - @ - f x = unsafePerformIO (newIORef [x]) - @ - because now it can't float outside the lambda. - -It is less well known that -'unsafePerformIO' is not type safe. For example: - -> test :: IORef [a] -> test = unsafePerformIO $ newIORef [] -> -> main = do -> writeIORef test [42] -> bang <- readIORef test -> print (bang :: [Char]) - -This program will core dump. This problem with polymorphic references -is well known in the ML community, and does not arise with normal -monadic use of references. There is no easy way to make it impossible -once you use 'unsafePerformIO'. Indeed, it is -possible to write @coerce :: a -> b@ with the -help of 'unsafePerformIO'. So be careful! --} -unsafePerformIO :: IO a -> a -unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) - -{-| -This version of 'unsafePerformIO' is more efficient -because it omits the check that the IO is only being performed by a -single thread. Hence, when you use 'unsafeDupablePerformIO', -there is a possibility that the IO action may be performed multiple -times (on a multiprocessor), and you should therefore ensure that -it gives the same results each time. It may even happen that one -of the duplicated IO actions is only run partially, and then interrupted -in the middle without an exception being raised. Therefore, functions -like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'. - -@since 4.4.0.0 --} -{-# NOINLINE unsafeDupablePerformIO #-} - -- See Note [unsafeDupablePerformIO is NOINLINE] -unsafeDupablePerformIO :: IO a -> a -unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) - -- See Note [unsafeDupablePerformIO has a lazy RHS] - --- Note [unsafeDupablePerformIO is NOINLINE] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we NOINLINE unsafeDupablePerformIO? See the comment with --- GHC.ST.runST. Essentially the issue is that the IO computation --- inside unsafePerformIO must be atomic: it must either all run, or --- not at all. If we let the compiler see the application of the IO --- to realWorld#, it might float out part of the IO. - --- Note [unsafeDupablePerformIO has a lazy RHS] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why is there a call to 'lazy' in unsafeDupablePerformIO? --- If we don't have it, the demand analyser discovers the following strictness --- for unsafeDupablePerformIO: C(U(AV)) --- But then consider --- unsafeDupablePerformIO (\s -> let r = f x in --- case writeIORef v r s of (# s1, _ #) -> --- (# s1, r #) ) --- The strictness analyser will find that the binding for r is strict, --- (because of uPIO's strictness sig), and so it'll evaluate it before --- doing the writeIORef. This actually makes libraries/base/tests/memo002 --- get a deadlock, where we specifically wanted to write a lazy thunk --- into the ref cell. --- --- Solution: don't expose the strictness of unsafeDupablePerformIO, --- by hiding it with 'lazy' --- But see discussion in Trac #9390 (comment:33) - -{-| -'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily. -When passed a value of type @IO a@, the 'IO' will only be performed -when the value of the @a@ is demanded. This is used to implement lazy -file reading, see 'System.IO.hGetContents'. --} -{-# INLINE unsafeInterleaveIO #-} -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) - --- We used to believe that INLINE on unsafeInterleaveIO was safe, --- because the state from this IO thread is passed explicitly to the --- interleaved IO, so it cannot be floated out and shared. --- --- HOWEVER, if the compiler figures out that r is used strictly here, --- then it will eliminate the thunk and the side effects in m will no --- longer be shared in the way the programmer was probably expecting, --- but can be performed many times. In #5943, this broke our --- definition of fixIO, which contains --- --- ans <- unsafeInterleaveIO (takeMVar m) --- --- after inlining, we lose the sharing of the takeMVar, so the second --- time 'ans' was demanded we got a deadlock. We could fix this with --- a readMVar, but it seems wrong for unsafeInterleaveIO to sometimes --- share and sometimes not (plus it probably breaks the noDuplicate). --- So now, we do not inline unsafeDupableInterleaveIO. - -{-# NOINLINE unsafeDupableInterleaveIO #-} -unsafeDupableInterleaveIO :: IO a -> IO a -unsafeDupableInterleaveIO (IO m) - = IO ( \ s -> let - r = case m s of (# _, res #) -> res - in - (# s, r #)) - -{-| -Ensures that the suspensions under evaluation by the current thread -are unique; that is, the current thread is not evaluating anything -that is also under evaluation by another thread that has also executed -'noDuplicate'. - -This operation is used in the definition of 'unsafePerformIO' to -prevent the IO action from being executed multiple times, which is usually -undesirable. --} -noDuplicate :: IO () -noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) - -- ----------------------------------------------------------------------------- -- | File and directory names are values of type 'String', whose precise -- meaning is operating system dependent. Files can be opened, yielding a @@ -282,16 +126,32 @@ have to work around that in the definition of catchException below). -} +-- | Catch an exception in the 'IO' monad. +-- +-- Note that this function is /strict/ in the action. That is, +-- @catchException undefined b == _|_@. See #exceptions_and_strictness# +-- for details. catchException :: Exception e => IO a -> (e -> IO a) -> IO a catchException (IO io) handler = IO $ catch# io handler' where handler' e = case fromException e of Just e' -> unIO (handler e') Nothing -> raiseIO# e +-- | Catch any 'Exception' type in the 'IO' monad. +-- +-- Note that this function is /strict/ in the action. That is, +-- @catchException undefined b == _|_@. See #exceptions_and_strictness# for +-- details. catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a catchAny (IO io) handler = IO $ catch# io handler' where handler' (SomeException e) = unIO (handler e) + +mplusIO :: IO a -> IO a -> IO a +mplusIO m n = m `catchIOError` \ _ -> n + where catchIOError :: IO a -> (IOError -> IO a) -> IO a + catchIOError = catchException + -- | A variant of 'throw' that can only be used within the 'IO' monad. -- -- Although 'throwIO' has a type that is an instance of the type of 'throw', the @@ -341,6 +201,22 @@ unsafeUnmask :: IO a -> IO a unsafeUnmask (IO io) = IO $ unmaskAsyncExceptions# io +-- | Allow asynchronous exceptions to be raised even inside 'mask', making +-- the operation interruptible (see the discussion of "Interruptible operations" +-- in 'Control.Exception'). +-- +-- When called outside 'mask', or inside 'uninterruptibleMask', this +-- function has no effect. +-- +-- @since 4.9.0.0 +interruptible :: IO a -> IO a +interruptible act = do + st <- getMaskingState + case st of + Unmasked -> act + MaskedInterruptible -> unsafeUnmask act + MaskedUninterruptible -> act + blockUninterruptible :: IO a -> IO a blockUninterruptible (IO io) = IO $ maskUninterruptible# io @@ -471,20 +347,68 @@ _ <- sequel return r --- | Forces its argument to be evaluated to weak head normal form when --- the resultant 'IO' action is executed. It can be used to order --- evaluation with respect to other 'IO' operations; its semantics are --- given by +-- | Evaluate the argument to weak head normal form. -- --- > evaluate x `seq` y ==> y --- > evaluate x `catch` f ==> (return $! x) `catch` f --- > evaluate x >>= f ==> (return $! x) >>= f +-- 'evaluate' is typically used to uncover any exceptions that a lazy value +-- may contain, and possibly handle them. -- --- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the --- same as @(return $! x)@. A correct definition is +-- 'evaluate' only evaluates to /weak head normal form/. If deeper +-- evaluation is needed, the @force@ function from @Control.DeepSeq@ +-- may be handy: -- --- > evaluate x = (return $! x) >>= return +-- > evaluate $ force x -- +-- There is a subtle difference between @'evaluate' x@ and @'return' '$!' x@, +-- analogous to the difference between 'throwIO' and 'throw'. If the lazy +-- value @x@ throws an exception, @'return' '$!' x@ will fail to return an +-- 'IO' action and will throw an exception instead. @'evaluate' x@, on the +-- other hand, always produces an 'IO' action; that action will throw an +-- exception upon /execution/ iff @x@ throws an exception upon /evaluation/. +-- +-- The practical implication of this difference is that due to the +-- /imprecise exceptions/ semantics, +-- +-- > (return $! error "foo") >> error "bar" +-- +-- may throw either @"foo"@ or @"bar"@, depending on the optimizations +-- performed by the compiler. On the other hand, +-- +-- > evaluate (error "foo") >> error "bar" +-- +-- is guaranteed to throw @"foo"@. +-- +-- The rule of thumb is to use 'evaluate' to force or handle exceptions in +-- lazy values. If, on the other hand, you are forcing a lazy value for +-- efficiency reasons only and do not care about exceptions, you may +-- use @'return' '$!' x@. evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -- NB. see #2273, #5129 +{- $exceptions_and_strictness + +Laziness can interact with @catch@-like operations in non-obvious ways (see, +e.g. GHC Trac #11555). For instance, consider these subtly-different examples, + +> test1 = Control.Exception.catch (error "uh oh") (\(_ :: SomeException) -> putStrLn "it failed") +> +> test2 = GHC.IO.catchException (error "uh oh") (\(_ :: SomeException) -> putStrLn "it failed") + +While the first case is always guaranteed to print "it failed", the behavior of +@test2@ may vary with optimization level. + +The unspecified behavior of @test2@ is due to the fact that GHC may assume that +'catchException' (and the 'catch#' primitive operation which it is built upon) +is strict in its first argument. This assumption allows the compiler to better +optimize @catchException@ calls at the expense of deterministic behavior when +the action may be bottom. + +Namely, the assumed strictness means that exceptions thrown while evaluating the +action-to-be-executed may not be caught; only exceptions thrown during execution +of the action will be handled by the exception handler. + +Since this strictness is a small optimization and may lead to surprising +results, all of the @catch@ and @handle@ variants offered by "Control.Exception" +are lazy in their first argument. If you are certain that that the action to be +executed won't bottom in performance-sensitive code, you might consider using +'GHC.IO.catchException' or 'GHC.IO.catchAny' for a small speed-up. +-} diff --git a/GHC/IO.hs-boot b/GHC/IO.hs-boot --- a/GHC/IO.hs-boot +++ b/GHC/IO.hs-boot @@ -6,4 +6,4 @@ import GHC.Types 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 @@ -287,5 +287,5 @@ check :: Buffer a -> Bool -> IO () check _ True = return () -check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf) +check buf False = errorWithoutStackTrace ("buffer invariant violation: " ++ summaryBuffer buf) diff --git a/GHC/IO/Encoding.hs b/GHC/IO/Encoding.hs --- a/GHC/IO/Encoding.hs +++ b/GHC/IO/Encoding.hs @@ -245,6 +245,8 @@ "UTF32" -> return $ UTF32.mkUTF32 cfm "UTF32LE" -> return $ UTF32.mkUTF32le cfm "UTF32BE" -> return $ UTF32.mkUTF32be cfm + -- ISO8859-1 we can handle ourselves as well + "ISO88591" -> return $ Latin1.mkLatin1 cfm #if defined(mingw32_HOST_OS) 'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp _ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm) diff --git a/GHC/IO/Encoding/CodePage/API.hs b/GHC/IO/Encoding/CodePage/API.hs --- a/GHC/IO/Encoding/CodePage/API.hs +++ b/GHC/IO/Encoding/CodePage/API.hs @@ -1,7 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, NondecreasingIndentation, RecordWildCards, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} module GHC.IO.Encoding.CodePage.API ( mkCodePageEncoding @@ -83,7 +83,7 @@ pokeArray' :: Storable a => String -> Int -> Ptr a -> [a] -> IO () pokeArray' msg sz ptr xs | length xs == sz = pokeArray ptr xs - | otherwise = error $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs) + | otherwise = errorWithoutStackTrace $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs) foreign import WINDOWS_CCONV unsafe "windows.h GetCPInfo" @@ -189,7 +189,7 @@ cwcharView :: Buffer Word8 -> Buffer CWchar cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufL = half bufL, bufR = half bufR } where half x = case x `divMod` 2 of (y, 0) -> y - _ -> error "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes" + _ -> errorWithoutStackTrace "cwcharView: utf16_(encode|decode) (wrote out|consumed) non multiple-of-2 number of bytes" utf16_native_encode :: CodeBuffer Char CWchar utf16_native_encode ibuf obuf = do @@ -227,9 +227,9 @@ -- If we successfully translate all of the UTF-16 buffer, we need to know why we couldn't get any more -- UTF-16 out of the Windows API InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf) - | otherwise -> error "cpDecode: impossible underflown UTF-16 buffer" + | otherwise -> errorWithoutStackTrace "cpDecode: impossible underflown UTF-16 buffer" -- InvalidSequence should be impossible since mbuf' is output from Windows. - InvalidSequence -> error "InvalidSequence on output of Windows API" + InvalidSequence -> errorWithoutStackTrace "InvalidSequence on output of Windows API" -- If we run out of space in obuf, we need to ask for more output buffer space, while also returning -- the characters we have managed to consume so far. OutputUnderflow -> do @@ -287,7 +287,7 @@ -- If we succesfully translate all of the UTF-16 buffer, we need to know why -- we weren't able to get any more UTF-16 out of the UTF-32 buffer InputUnderflow | isEmptyBuffer mbuf' -> return (why1, ibuf', obuf) - | otherwise -> error "cpEncode: impossible underflown UTF-16 buffer" + | otherwise -> errorWithoutStackTrace "cpEncode: impossible underflown UTF-16 buffer" -- With OutputUnderflow/InvalidSequence we only care about the failings of the UTF-16->CP translation. -- Yes, InvalidSequence is possible even though mbuf' is guaranteed to be valid UTF-16, because -- the code page may not be able to represent the encoded Unicode codepoint. @@ -371,9 +371,9 @@ LT -> go' (md+1) mx GT -> go' mn (md-1) go' mn mx | mn <= mx = go mn (mn + ((mx - mn) `div` 2)) mx - | otherwise = error $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx) + | otherwise = errorWithoutStackTrace $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx) -cpRecode :: forall from to. (Show from, Storable from) +cpRecode :: forall from to. Storable from => (Ptr from -> Int -> Ptr to -> Int -> IO (Either Bool Int)) -> (from -> IO Bool) -> Int -- ^ Maximum length of a complete translatable sequence in the input (e.g. 2 if the input is UTF-16, 1 if the input is a SBCS, 2 is the input is a DBCS). Must be at least 1. 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 @@ -74,21 +74,22 @@ -- unicode input that includes lone surrogate codepoints is invalid by -- definition. -- +-- -- When we used private-use characters there was a technical problem when it -- came to encoding back to bytes using iconv. The iconv code will not fail when -- it tries to encode a private-use character (as it would if trying to encode --- a surrogate), which means that we won't get a chance to replace it +-- a surrogate), which means that we wouldn't get a chance to replace it -- with the byte we originally escaped. -- -- To work around this, when filling the buffer to be encoded (in -- writeBlocks/withEncodedCString/newEncodedCString), we replaced the -- private-use characters with lone surrogates again! Likewise, when --- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we have +-- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we had -- to do the inverse process. -- -- The user of String would never see these lone surrogates, but it --- ensures that iconv will throw an error when encountering them. We --- use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose. +-- ensured that iconv will throw an error when encountering them. We +-- used lone surrogates in the range 0xDC00 to 0xDCFF for this purpose. codingFailureModeSuffix :: CodingFailureMode -> String codingFailureModeSuffix ErrorOnCodingFailure = "" diff --git a/GHC/IO/Encoding/Latin1.hs b/GHC/IO/Encoding/Latin1.hs --- a/GHC/IO/Encoding/Latin1.hs +++ b/GHC/IO/Encoding/Latin1.hs @@ -96,11 +96,11 @@ -- ----------------------------------------------------------------------------- -- ASCII --- | @since 4.8.2.0 +-- | @since 4.9.0.0 ascii :: TextEncoding ascii = mkAscii ErrorOnCodingFailure --- | @since 4.8.2.0 +-- | @since 4.9.0.0 mkAscii :: CodingFailureMode -> TextEncoding mkAscii cfm = TextEncoding { textEncodingName = "ASCII", mkTextDecoder = ascii_DF cfm, 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 @@ -123,7 +123,7 @@ -- | @since 4.4.0.0 data CodingProgress = InputUnderflow -- ^ Stopped because the input contains insufficient available elements, - -- or all of the input sequence has been sucessfully translated. + -- or all of the input sequence has been successfully translated. | OutputUnderflow -- ^ Stopped because the output contains insufficient free elements | InvalidSequence -- ^ Stopped because there are sufficient free elements in the output -- to output at least one encoded ASCII character, but the input contains diff --git a/GHC/IO/Exception.hs b/GHC/IO/Exception.hs --- a/GHC/IO/Exception.hs +++ b/GHC/IO/Exception.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, AutoDeriveTypeable, MagicHash, - ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash, + ExistentialQuantification, ImplicitParams #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -44,15 +44,18 @@ ) where import GHC.Base +import GHC.Generics import GHC.List import GHC.IO import GHC.Show import GHC.Read import GHC.Exception import GHC.IO.Handle.Types +import GHC.OldList ( intercalate ) +import {-# SOURCE #-} GHC.Stack.CCS import Foreign.C.Types -import Data.Typeable ( Typeable, cast ) +import Data.Typeable ( cast ) -- ------------------------------------------------------------------------ -- Exception datatypes and operations @@ -60,7 +63,6 @@ -- |The thread is blocked on an @MVar@, but there are no other references -- to the @MVar@ so it can't ever continue. data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar - deriving Typeable instance Exception BlockedIndefinitelyOnMVar @@ -75,7 +77,6 @@ -- |The thread is waiting to retry an STM transaction, but there are no -- other references to any @TVar@s involved, so it can't ever continue. data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM - deriving Typeable instance Exception BlockedIndefinitelyOnSTM @@ -90,7 +91,6 @@ -- |There are no runnable threads, so the program is deadlocked. -- The @Deadlock@ exception is raised in the main thread only. data Deadlock = Deadlock - deriving Typeable instance Exception Deadlock @@ -100,12 +100,11 @@ ----- -- |This thread has exceeded its allocation limit. See --- 'GHC.Conc.setAllocationCounter' and --- 'GHC.Conc.enableAllocationLimit'. +-- 'System.Mem.setAllocationCounter' and +-- 'System.Mem.enableAllocationLimit'. -- -- @since 4.8.0.0 data AllocationLimitExceeded = AllocationLimitExceeded - deriving Typeable instance Exception AllocationLimitExceeded where toException = asyncExceptionToException @@ -121,8 +120,7 @@ ----- -- |'assert' was applied to 'False'. -data AssertionFailed = AssertionFailed String - deriving Typeable +newtype AssertionFailed = AssertionFailed String instance Exception AssertionFailed @@ -135,7 +133,6 @@ -- -- @since 4.7.0.0 data SomeAsyncException = forall e . Exception e => SomeAsyncException e - deriving Typeable instance Show SomeAsyncException where show (SomeAsyncException e) = show e @@ -178,7 +175,7 @@ -- ^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, Typeable) + deriving (Eq, Ord) instance Exception AsyncException where toException = asyncExceptionToException @@ -192,7 +189,7 @@ | UndefinedElement String -- ^An attempt was made to evaluate an element of an -- array that had not been initialized. - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord) instance Exception ArrayException @@ -231,7 +228,7 @@ -- The exact interpretation of the code is -- operating-system dependent. In particular, some values -- may be prohibited (e.g. 0 on a POSIX-compliant system). - deriving (Eq, Ord, Read, Show, Typeable) + deriving (Eq, Ord, Read, Show, Generic) instance Exception ExitCode @@ -248,7 +245,7 @@ -- | The Haskell 2010 type for exceptions in the 'IO' monad. -- Any I\/O operation may raise an 'IOError' instead of returning a result. -- For a more general type of exception, including also those that arise --- in pure code, see "Control.Exception.Exception". +-- in pure code, see 'Control.Exception.Exception'. -- -- In Haskell 2010, this is an opaque type. type IOError = IOException @@ -267,7 +264,6 @@ ioe_errno :: Maybe CInt, -- errno leading to this error, if any. ioe_filename :: Maybe FilePath -- filename the error is related to. } - deriving Typeable instance Exception IOException @@ -358,10 +354,16 @@ -- Note the use of "lazy". This means that -- assert False (throw e) -- will throw the assertion failure rather than e. See trac #5561. -assertError :: Addr# -> Bool -> a -> a -assertError str predicate v +assertError :: (?callStack :: CallStack) => Bool -> a -> a +assertError predicate v | predicate = lazy v - | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + | otherwise = unsafeDupablePerformIO $ do + ccsStack <- currentCallStack + let + implicitParamCallStack = prettyCallStackLines ?callStack + ccsCallStack = showCCSStack ccsStack + stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack + throwIO (AssertionFailed ("Assertion failed\n" ++ stack)) unsupportedOperation :: IOError unsupportedOperation = diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -2,9 +2,8 @@ {-# LANGUAGE CPP , NoImplicitPrelude , BangPatterns - , AutoDeriveTypeable #-} -{-# OPTIONS_GHC -fno-warn-identities #-} +{-# OPTIONS_GHC -Wno-identities #-} -- Whether there are identities depends on the platform {-# OPTIONS_HADDOCK hide #-} @@ -35,7 +34,6 @@ import GHC.Real import GHC.Show import GHC.Enum -import Data.Typeable import GHC.IO import GHC.IO.IOMode @@ -84,7 +82,6 @@ fdIsNonBlocking :: {-# UNPACK #-} !Int #endif } - deriving Typeable #ifdef mingw32_HOST_OS fdIsSocket :: FD -> Bool diff --git a/GHC/IO/Handle.hs b/GHC/IO/Handle.hs --- a/GHC/IO/Handle.hs +++ b/GHC/IO/Handle.hs @@ -4,7 +4,7 @@ , RecordWildCards , NondecreasingIndentation #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} ----------------------------------------------------------------------------- -- | @@ -113,7 +113,7 @@ withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do case haType handle_ of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle _ -> do flushWriteBuffer handle_ r <- IODevice.getSize dev if r /= -1 @@ -129,7 +129,7 @@ withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do case haType handle_ of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle _ -> do flushWriteBuffer handle_ IODevice.setSize dev size return () @@ -255,7 +255,7 @@ closeTextCodecs h_ openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do bbuf <- readIORef haByteBuffer - ref <- newIORef (error "last_decode") + ref <- newIORef (errorWithoutStackTrace "last_decode") return (Handle__{ haLastDecode = ref, haDecoder = mb_decoder, haEncoder = mb_encoder, @@ -473,7 +473,7 @@ withHandle_ "hIsReadable" handle $ \ handle_ -> do case haType handle_ of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle htype -> return (isReadableHandleType htype) hIsWritable :: Handle -> IO Bool @@ -482,7 +482,7 @@ withHandle_ "hIsWritable" handle $ \ handle_ -> do case haType handle_ of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle htype -> return (isWritableHandleType htype) -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode @@ -503,12 +503,12 @@ withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do case haType of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle AppendHandle -> return False _ -> IODevice.isSeekable haDevice -- ----------------------------------------------------------------------------- --- Changing echo status (Non-standard GHC extensions) +-- Changing echo status -- | Set the echoing status of a handle connected to a terminal. @@ -571,7 +571,7 @@ | otherwise = nativeNewlineMode bbuf <- readIORef haByteBuffer - ref <- newIORef (error "codec_state", bbuf) + ref <- newIORef (errorWithoutStackTrace "codec_state", bbuf) return Handle__{ haLastDecode = ref, haEncoder = mb_encoder, diff --git a/GHC/IO/Handle/FD.hs b/GHC/IO/Handle/FD.hs --- a/GHC/IO/Handle/FD.hs +++ b/GHC/IO/Handle/FD.hs @@ -153,9 +153,9 @@ (\e -> ioError (addFilePathToIOError "openFile" fp e)) -- | Like 'openFile', but opens the file in ordinary blocking mode. --- This can be useful for opening a FIFO for reading: if we open in --- non-blocking mode then the open will fail if there are no writers, --- whereas a blocking open will block until a writer appears. +-- This can be useful for opening a FIFO for writing: if we open in +-- non-blocking mode then the open will fail if there are no readers, +-- whereas a blocking open will block until a reader appear. -- -- @since 4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -5,8 +5,8 @@ , NondecreasingIndentation , RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -42,7 +42,8 @@ decodeByteBuf, augmentIOError, - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, + ioe_closedHandle, ioe_semiclosedHandle, + ioe_EOF, ioe_notReadable, ioe_notWritable, ioe_finalizedHandle, ioe_bufsiz, hClose_help, hLookAhead_, @@ -238,7 +239,7 @@ checkWritableHandle act h_@Handle__{..} = case haType of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle ReadHandle -> ioe_notWritable ReadWriteHandle -> do buf <- readIORef haCharBuffer @@ -277,7 +278,7 @@ checkReadableHandle act h_@Handle__{..} = case haType of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle AppendHandle -> ioe_notReadable WriteHandle -> ioe_notReadable ReadWriteHandle -> do @@ -307,7 +308,7 @@ checkSeekableHandle act handle_@Handle__{haDevice=dev} = case haType handle_ of ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_semiclosedHandle AppendHandle -> ioe_notSeekable _ -> do b <- IODevice.isSeekable dev if b then act handle_ @@ -316,13 +317,16 @@ -- ----------------------------------------------------------------------------- -- Handy IOErrors -ioe_closedHandle, ioe_EOF, +ioe_closedHandle, ioe_semiclosedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable, ioe_notSeekable :: IO a ioe_closedHandle = ioException (IOError Nothing IllegalOperation "" "handle is closed" Nothing Nothing) +ioe_semiclosedHandle = ioException + (IOError Nothing IllegalOperation "" + "handle is semi-closed" Nothing Nothing) ioe_EOF = ioException (IOError Nothing EOF "" "" Nothing Nothing) ioe_notReadable = ioException @@ -476,15 +480,19 @@ ReadBuffer -> do flushCharReadBuffer h_ WriteBuffer -> + -- Nothing to do here. Char buffer on a write Handle is always empty + -- between Handle operations. + -- See [note Buffer Flushing], GHC.IO.Handle.Types. when (not (isEmptyBuffer cbuf)) $ error "internal IO library error: Char buffer non-empty" -- ----------------------------------------------------------------------------- -- Writing data (flushing write buffers) --- flushWriteBuffer flushes the buffer iff it contains pending write --- data. Flushes both the Char and the byte buffer, leaving both --- empty. +-- flushWriteBuffer flushes the byte buffer iff it contains pending write +-- data. Because the Char buffer on a write Handle is always empty between +-- Handle operations (see [note Buffer Flushing], GHC.IO.Handle.Types), +-- both buffers are empty after this. flushWriteBuffer :: Handle__ -> IO () flushWriteBuffer h_@Handle__{..} = do buf <- readIORef haByteBuffer @@ -515,7 +523,7 @@ debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++ " bbuf=" ++ summaryBuffer bbuf') - -- flush if the write buffer is full + -- flush the byte buffer if it is full if isFullBuffer bbuf' -- or we made no progress || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf @@ -620,7 +628,7 @@ let buf_state = initBufferState ha_type bbuf <- Buffered.newBuffer dev buf_state bbufref <- newIORef bbuf - last_decode <- newIORef (error "codec_state", bbuf) + last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf) (cbufref,bmode) <- if buffered then getCharBuffer dev buf_state @@ -840,7 +848,7 @@ (bbuf2,cbuf') <- case haDecoder of Nothing -> do - writeIORef haLastDecode (error "codec_state", bbuf1) + writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf1) latin1_decode bbuf1 cbuf Just decoder -> do state <- getState decoder @@ -929,7 +937,7 @@ (bbuf2,cbuf') <- case haDecoder of Nothing -> do - writeIORef haLastDecode (error "codec_state", bbuf0) + writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf0) latin1_decode bbuf0 cbuf Just decoder -> do state <- getState decoder 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 @@ -6,8 +6,8 @@ , NondecreasingIndentation , MagicHash #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -246,7 +246,7 @@ maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = Exception.catch + = catchException (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) @@ -564,7 +564,7 @@ haBufferMode=mode} = do case mode of - NoBuffering -> return (mode, error "no buffer!") + NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!") _ -> do bufs <- readIORef spare_ref buf <- readIORef ref 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 @@ -2,7 +2,6 @@ {-# LANGUAGE CPP , NoImplicitPrelude , ExistentialQuantification - , AutoDeriveTypeable #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -109,8 +108,6 @@ !(MVar Handle__) -- The read side !(MVar Handle__) -- The write side - deriving Typeable - -- NOTES: -- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be -- seekable. @@ -125,10 +122,10 @@ Handle__ { haDevice :: !dev, haType :: HandleType, -- type (read/write/append etc.) - haByteBuffer :: !(IORef (Buffer Word8)), + haByteBuffer :: !(IORef (Buffer Word8)), -- See [note Buffering Implementation] haBufferMode :: BufferMode, haLastDecode :: !(IORef (dec_state, Buffer Word8)), - haCharBuffer :: !(IORef (Buffer CharBufElem)), -- the current buffer + haCharBuffer :: !(IORef (Buffer CharBufElem)), -- See [note Buffering Implementation] haBuffers :: !(IORef (BufferList CharBufElem)), -- spare buffers haEncoder :: Maybe (TextEncoder enc_state), haDecoder :: Maybe (TextDecoder dec_state), @@ -138,7 +135,6 @@ haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a -- duplex handle. } - deriving Typeable -- we keep a few spare buffers around in a handle to avoid allocating -- a new one for each hPutStr. These buffers are *guaranteed* to be the @@ -189,10 +185,10 @@ cbuf <- readIORef (haCharBuffer h_) checkBuffer cbuf when (isWriteBuffer cbuf && not (isEmptyBuffer cbuf)) $ - error ("checkHandleInvariants: char write buffer non-empty: " ++ + errorWithoutStackTrace ("checkHandleInvariants: char write buffer non-empty: " ++ summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf) when (isWriteBuffer bbuf /= isWriteBuffer cbuf) $ - error ("checkHandleInvariants: buffer modes differ: " ++ + errorWithoutStackTrace ("checkHandleInvariants: buffer modes differ: " ++ summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf) #else diff --git a/GHC/IO/Unsafe.hs b/GHC/IO/Unsafe.hs new file mode 100644 --- /dev/null +++ b/GHC/IO/Unsafe.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE NoImplicitPrelude + , MagicHash + , UnboxedTuples + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Unsafe +-- Copyright : (c) The University of Glasgow 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Unsafe IO operations +-- +----------------------------------------------------------------------------- + +module GHC.IO.Unsafe ( + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + ) where + +import GHC.Base + + +{-| +This is the \"back door\" into the 'IO' monad, allowing +'IO' computation to be performed at any time. For +this to be safe, the 'IO' computation should be +free of side effects and independent of its environment. + +If the I\/O computation wrapped in 'unsafePerformIO' performs side +effects, then the relative order in which those side effects take +place (relative to the main I\/O trunk, or other calls to +'unsafePerformIO') is indeterminate. Furthermore, when using +'unsafePerformIO' to cause side-effects, you should take the following +precautions to ensure the side effects are performed as many times as +you expect them to be. Note that these precautions are necessary for +GHC, but may not be sufficient, and other compilers may require +different precautions: + + * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ + that calls 'unsafePerformIO'. If the call is inlined, + the I\/O may be performed more than once. + + * Use the compiler flag @-fno-cse@ to prevent common sub-expression + elimination being performed on the module, which might combine + two side effects that were meant to be separate. A good example + is using multiple global variables (like @test@ in the example below). + + * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the + call to 'unsafePerformIO' cannot float outside a lambda. For example, + if you say: + @ + f x = unsafePerformIO (newIORef []) + @ + you may get only one reference cell shared between all calls to @f@. + Better would be + @ + f x = unsafePerformIO (newIORef [x]) + @ + because now it can't float outside the lambda. + +It is less well known that +'unsafePerformIO' is not type safe. For example: + +> test :: IORef [a] +> test = unsafePerformIO $ newIORef [] +> +> main = do +> writeIORef test [42] +> bang <- readIORef test +> print (bang :: [Char]) + +This program will core dump. This problem with polymorphic references +is well known in the ML community, and does not arise with normal +monadic use of references. There is no easy way to make it impossible +once you use 'unsafePerformIO'. Indeed, it is +possible to write @coerce :: a -> b@ with the +help of 'unsafePerformIO'. So be careful! +-} +unsafePerformIO :: IO a -> a +unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) + +{-| +This version of 'unsafePerformIO' is more efficient +because it omits the check that the IO is only being performed by a +single thread. Hence, when you use 'unsafeDupablePerformIO', +there is a possibility that the IO action may be performed multiple +times (on a multiprocessor), and you should therefore ensure that +it gives the same results each time. It may even happen that one +of the duplicated IO actions is only run partially, and then interrupted +in the middle without an exception being raised. Therefore, functions +like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'. + +@since 4.4.0.0 +-} +unsafeDupablePerformIO :: IO a -> a +unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> a + +-- Note [unsafeDupablePerformIO is NOINLINE] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with +-- GHC.ST.runST. Essentially the issue is that the IO computation +-- inside unsafePerformIO must be atomic: it must either all run, or +-- not at all. If we let the compiler see the application of the IO +-- to realWorld#, it might float out part of the IO. + +-- Note [unsafeDupablePerformIO has a lazy RHS] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why is there a call to 'lazy' in unsafeDupablePerformIO? +-- If we don't have it, the demand analyser discovers the following strictness +-- for unsafeDupablePerformIO: C(U(AV)) +-- But then consider +-- unsafeDupablePerformIO (\s -> let r = f x in +-- case writeIORef v r s of (# s1, _ #) -> +-- (# s1, r #) ) +-- The strictness analyser will find that the binding for r is strict, +-- (because of uPIO's strictness sig), and so it'll evaluate it before +-- doing the writeIORef. This actually makes libraries/base/tests/memo002 +-- get a deadlock, where we specifically wanted to write a lazy thunk +-- into the ref cell. +-- +-- Solution: don't expose the strictness of unsafeDupablePerformIO, +-- by hiding it with 'lazy' +-- But see discussion in Trac #9390 (comment:33) + +{-| +'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily. +When passed a value of type @IO a@, the 'IO' will only be performed +when the value of the @a@ is demanded. This is used to implement lazy +file reading, see 'System.IO.hGetContents'. +-} +{-# INLINE unsafeInterleaveIO #-} +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) + +-- We used to believe that INLINE on unsafeInterleaveIO was safe, +-- because the state from this IO thread is passed explicitly to the +-- interleaved IO, so it cannot be floated out and shared. +-- +-- HOWEVER, if the compiler figures out that r is used strictly here, +-- then it will eliminate the thunk and the side effects in m will no +-- longer be shared in the way the programmer was probably expecting, +-- but can be performed many times. In #5943, this broke our +-- definition of fixIO, which contains +-- +-- ans <- unsafeInterleaveIO (takeMVar m) +-- +-- after inlining, we lose the sharing of the takeMVar, so the second +-- time 'ans' was demanded we got a deadlock. We could fix this with +-- a readMVar, but it seems wrong for unsafeInterleaveIO to sometimes +-- share and sometimes not (plus it probably breaks the noDuplicate). +-- So now, we do not inline unsafeDupableInterleaveIO. + +{-# NOINLINE unsafeDupableInterleaveIO #-} +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) + +{-| +Ensures that the suspensions under evaluation by the current thread +are unique; that is, the current thread is not evaluating anything +that is also under evaluation by another thread that has also executed +'noDuplicate'. + +This operation is used in the definition of 'unsafePerformIO' to +prevent the IO action from being executed multiple times, which is usually +undesirable. +-} +noDuplicate :: IO () +noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) diff --git a/GHC/IOArray.hs b/GHC/IOArray.hs --- a/GHC/IOArray.hs +++ b/GHC/IOArray.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Unsafe #-} -{-# LANGUAGE NoImplicitPrelude, AutoDeriveTypeable, RoleAnnotations #-} +{-# LANGUAGE NoImplicitPrelude, RoleAnnotations #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -27,7 +27,6 @@ import GHC.Base import GHC.IO import GHC.Arr -import Data.Typeable.Internal -- --------------------------------------------------------------------------- -- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. @@ -39,7 +38,7 @@ -- -- -newtype IOArray i e = IOArray (STArray RealWorld i e) deriving( Typeable ) +newtype IOArray i e = IOArray (STArray RealWorld i e) -- index type should have a nominal role due to Ix class. See also #9220. type role IOArray nominal representational @@ -54,12 +53,12 @@ newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)} -- | Read a value from an 'IOArray' -unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e +unsafeReadIOArray :: IOArray i e -> Int -> IO e {-# INLINE unsafeReadIOArray #-} unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i) -- | Write a new value into an 'IOArray' -unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO () +unsafeWriteIOArray :: IOArray i e -> Int -> e -> IO () {-# INLINE unsafeWriteIOArray #-} unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e) diff --git a/GHC/IORef.hs b/GHC/IORef.hs --- a/GHC/IORef.hs +++ b/GHC/IORef.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Unsafe #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, AutoDeriveTypeable #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -25,13 +25,12 @@ import GHC.Base import GHC.STRef import GHC.IO -import Data.Typeable.Internal( Typeable ) -- --------------------------------------------------------------------------- -- IORefs -- |A mutable variable in the 'IO' monad -newtype IORef a = IORef (STRef RealWorld a) deriving( Typeable ) +newtype IORef a = IORef (STRef RealWorld a) -- explicit instance because Haddock can't figure out a derived one instance Eq (IORef a) where diff --git a/GHC/IP.hs b/GHC/IP.hs deleted file mode 100644 --- a/GHC/IP.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | @since 4.6.0.0 -module GHC.IP (IP(..)) where - -import GHC.TypeLits - --- | The syntax @?x :: a@ is desugared into @IP "x" a@ -class IP (x :: Symbol) a | x -> a where - ip :: a - - diff --git a/GHC/Int.hs b/GHC/Int.hs --- a/GHC/Int.hs +++ b/GHC/Int.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, UnboxedTuples, - StandaloneDeriving, AutoDeriveTypeable, NegativeLiterals #-} + StandaloneDeriving, NegativeLiterals #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -20,8 +20,15 @@ #include "MachDeps.h" module GHC.Int ( - Int8(..), Int16(..), Int32(..), Int64(..), - uncheckedIShiftL64#, uncheckedIShiftRA64# + Int(..), Int8(..), Int16(..), Int32(..), Int64(..), + uncheckedIShiftL64#, uncheckedIShiftRA64#, + -- * Equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + eqInt, neInt, gtInt, geInt, ltInt, leInt, + eqInt8, neInt8, gtInt8, geInt8, ltInt8, leInt8, + eqInt16, neInt16, gtInt16, geInt16, ltInt16, leInt16, + eqInt32, neInt32, gtInt32, geInt32, ltInt32, leInt32, + eqInt64, neInt64, gtInt64, geInt64, ltInt64, leInt64 ) where import Data.Bits @@ -39,9 +46,7 @@ import GHC.Arr import GHC.Word hiding (uncheckedShiftL64#, uncheckedShiftRL64#) import GHC.Show -import Data.Typeable - ------------------------------------------------------------------------ -- type Int8 ------------------------------------------------------------------------ @@ -49,9 +54,36 @@ -- Int8 is represented in the same way as Int. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsInt8" #-} Int8 = I8# Int# deriving (Eq, Ord, Typeable) +data {-# CTYPE "HsInt8" #-} Int8 = I8# Int# -- ^ 8-bit signed integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Int8 where + (==) = eqInt8 + (/=) = neInt8 + +eqInt8, neInt8 :: Int8 -> Int8 -> Bool +eqInt8 (I8# x) (I8# y) = isTrue# (x ==# y) +neInt8 (I8# x) (I8# y) = isTrue# (x /=# y) +{-# INLINE [1] eqInt8 #-} +{-# INLINE [1] neInt8 #-} + +instance Ord Int8 where + (<) = ltInt8 + (<=) = leInt8 + (>=) = geInt8 + (>) = gtInt8 + +{-# INLINE [1] gtInt8 #-} +{-# INLINE [1] geInt8 #-} +{-# INLINE [1] ltInt8 #-} +{-# INLINE [1] leInt8 #-} +gtInt8, geInt8, ltInt8, leInt8 :: Int8 -> Int8 -> Bool +(I8# x) `gtInt8` (I8# y) = isTrue# (x ># y) +(I8# x) `geInt8` (I8# y) = isTrue# (x >=# y) +(I8# x) `ltInt8` (I8# y) = isTrue# (x <# y) +(I8# x) `leInt8` (I8# y) = isTrue# (x <=# y) + instance Show Int8 where showsPrec p x = showsPrec p (fromIntegral x :: Int) @@ -210,9 +242,36 @@ -- Int16 is represented in the same way as Int. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsInt16" #-} Int16 = I16# Int# deriving (Eq, Ord, Typeable) +data {-# CTYPE "HsInt16" #-} Int16 = I16# Int# -- ^ 16-bit signed integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Int16 where + (==) = eqInt16 + (/=) = neInt16 + +eqInt16, neInt16 :: Int16 -> Int16 -> Bool +eqInt16 (I16# x) (I16# y) = isTrue# (x ==# y) +neInt16 (I16# x) (I16# y) = isTrue# (x /=# y) +{-# INLINE [1] eqInt16 #-} +{-# INLINE [1] neInt16 #-} + +instance Ord Int16 where + (<) = ltInt16 + (<=) = leInt16 + (>=) = geInt16 + (>) = gtInt16 + +{-# INLINE [1] gtInt16 #-} +{-# INLINE [1] geInt16 #-} +{-# INLINE [1] ltInt16 #-} +{-# INLINE [1] leInt16 #-} +gtInt16, geInt16, ltInt16, leInt16 :: Int16 -> Int16 -> Bool +(I16# x) `gtInt16` (I16# y) = isTrue# (x ># y) +(I16# x) `geInt16` (I16# y) = isTrue# (x >=# y) +(I16# x) `ltInt16` (I16# y) = isTrue# (x <# y) +(I16# x) `leInt16` (I16# y) = isTrue# (x <=# y) + instance Show Int16 where showsPrec p x = showsPrec p (fromIntegral x :: Int) @@ -376,9 +435,36 @@ -- from its logical range. #endif -data {-# CTYPE "HsInt32" #-} Int32 = I32# Int# deriving (Eq, Ord, Typeable) +data {-# CTYPE "HsInt32" #-} Int32 = I32# Int# -- ^ 32-bit signed integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Int32 where + (==) = eqInt32 + (/=) = neInt32 + +eqInt32, neInt32 :: Int32 -> Int32 -> Bool +eqInt32 (I32# x) (I32# y) = isTrue# (x ==# y) +neInt32 (I32# x) (I32# y) = isTrue# (x /=# y) +{-# INLINE [1] eqInt32 #-} +{-# INLINE [1] neInt32 #-} + +instance Ord Int32 where + (<) = ltInt32 + (<=) = leInt32 + (>=) = geInt32 + (>) = gtInt32 + +{-# INLINE [1] gtInt32 #-} +{-# INLINE [1] geInt32 #-} +{-# INLINE [1] ltInt32 #-} +{-# INLINE [1] leInt32 #-} +gtInt32, geInt32, ltInt32, leInt32 :: Int32 -> Int32 -> Bool +(I32# x) `gtInt32` (I32# y) = isTrue# (x ># y) +(I32# x) `geInt32` (I32# y) = isTrue# (x >=# y) +(I32# x) `ltInt32` (I32# y) = isTrue# (x <# y) +(I32# x) `leInt32` (I32# y) = isTrue# (x <=# y) + instance Show Int32 where showsPrec p x = showsPrec p (fromIntegral x :: Int) @@ -553,19 +639,36 @@ #if WORD_SIZE_IN_BITS < 64 -data {-# CTYPE "HsInt64" #-} Int64 = I64# Int64# deriving( Typeable ) +data {-# CTYPE "HsInt64" #-} Int64 = I64# Int64# -- ^ 64-bit signed integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules instance Eq Int64 where - (I64# x#) == (I64# y#) = isTrue# (x# `eqInt64#` y#) - (I64# x#) /= (I64# y#) = isTrue# (x# `neInt64#` y#) + (==) = eqInt64 + (/=) = neInt64 +eqInt64, neInt64 :: Int64 -> Int64 -> Bool +eqInt64 (I64# x) (I64# y) = isTrue# (x `eqInt64#` y) +neInt64 (I64# x) (I64# y) = isTrue# (x `neInt64#` y) +{-# INLINE [1] eqInt64 #-} +{-# INLINE [1] neInt64 #-} + instance Ord Int64 where - (I64# x#) < (I64# y#) = isTrue# (x# `ltInt64#` y#) - (I64# x#) <= (I64# y#) = isTrue# (x# `leInt64#` y#) - (I64# x#) > (I64# y#) = isTrue# (x# `gtInt64#` y#) - (I64# x#) >= (I64# y#) = isTrue# (x# `geInt64#` y#) + (<) = ltInt64 + (<=) = leInt64 + (>=) = geInt64 + (>) = gtInt64 +{-# INLINE [1] gtInt64 #-} +{-# INLINE [1] geInt64 #-} +{-# INLINE [1] ltInt64 #-} +{-# INLINE [1] leInt64 #-} +gtInt64, geInt64, ltInt64, leInt64 :: Int64 -> Int64 -> Bool +(I64# x) `gtInt64` (I64# y) = isTrue# (x `gtInt64#` y) +(I64# x) `geInt64` (I64# y) = isTrue# (x `geInt64#` y) +(I64# x) `ltInt64` (I64# y) = isTrue# (x `ltInt64#` y) +(I64# x) `leInt64` (I64# y) = isTrue# (x `leInt64#` y) + instance Show Int64 where showsPrec p x = showsPrec p (toInteger x) @@ -728,8 +831,35 @@ -- Operations may assume and must ensure that it holds only values -- from its logical range. -data {-# CTYPE "HsInt64" #-} Int64 = I64# Int# deriving (Eq, Ord, Typeable) +data {-# CTYPE "HsInt64" #-} Int64 = I64# Int# -- ^ 64-bit signed integer type + +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Int64 where + (==) = eqInt64 + (/=) = neInt64 + +eqInt64, neInt64 :: Int64 -> Int64 -> Bool +eqInt64 (I64# x) (I64# y) = isTrue# (x ==# y) +neInt64 (I64# x) (I64# y) = isTrue# (x /=# y) +{-# INLINE [1] eqInt64 #-} +{-# INLINE [1] neInt64 #-} + +instance Ord Int64 where + (<) = ltInt64 + (<=) = leInt64 + (>=) = geInt64 + (>) = gtInt64 + +{-# INLINE [1] gtInt64 #-} +{-# INLINE [1] geInt64 #-} +{-# INLINE [1] ltInt64 #-} +{-# INLINE [1] leInt64 #-} +gtInt64, geInt64, ltInt64, leInt64 :: Int64 -> Int64 -> Bool +(I64# x) `gtInt64` (I64# y) = isTrue# (x ># y) +(I64# x) `geInt64` (I64# y) = isTrue# (x >=# y) +(I64# x) `ltInt64` (I64# y) = isTrue# (x <# y) +(I64# x) `leInt64` (I64# y) = isTrue# (x <=# y) instance Show Int64 where showsPrec p x = showsPrec p (fromIntegral x :: Int) diff --git a/GHC/List.hs b/GHC/List.hs --- a/GHC/List.hs +++ b/GHC/List.hs @@ -400,39 +400,27 @@ -- It is a special case of 'Data.List.maximumBy', which allows the -- programmer to supply their own comparison function. maximum :: (Ord a) => [a] -> a -{-# INLINE [1] maximum #-} +{-# INLINEABLE maximum #-} maximum [] = errorEmptyList "maximum" maximum xs = foldl1 max xs -{-# RULES - "maximumInt" maximum = (strictMaximum :: [Int] -> Int); - "maximumInteger" maximum = (strictMaximum :: [Integer] -> Integer) - #-} - --- We can't make the overloaded version of maximum strict without --- changing its semantics (max might not be strict), but we can for --- the version specialised to 'Int'. -strictMaximum :: (Ord a) => [a] -> a -strictMaximum [] = errorEmptyList "maximum" -strictMaximum xs = foldl1' max xs +-- We want this to be specialized so that with a strict max function, GHC +-- produces good code. Note that to see if this is happending, one has to +-- look at -ddump-prep, not -ddump-core! +{-# SPECIALIZE maximum :: [Int] -> Int #-} +{-# SPECIALIZE maximum :: [Integer] -> Integer #-} -- | 'minimum' returns the minimum value from a list, -- which must be non-empty, finite, and of an ordered type. -- It is a special case of 'Data.List.minimumBy', which allows the -- programmer to supply their own comparison function. minimum :: (Ord a) => [a] -> a -{-# INLINE [1] minimum #-} +{-# INLINEABLE minimum #-} minimum [] = errorEmptyList "minimum" minimum xs = foldl1 min xs -{-# RULES - "minimumInt" minimum = (strictMinimum :: [Int] -> Int); - "minimumInteger" minimum = (strictMinimum :: [Integer] -> Integer) - #-} - -strictMinimum :: (Ord a) => [a] -> a -strictMinimum [] = errorEmptyList "minimum" -strictMinimum xs = foldl1' min xs +{-# SPECIALIZE minimum :: [Int] -> Int #-} +{-# SPECIALIZE minimum :: [Integer] -> Integer #-} -- | 'iterate' @f x@ returns an infinite list of repeated applications @@ -853,8 +841,8 @@ -- which takes an index of any integral type. (!!) :: [a] -> Int -> a #ifdef USE_REPORT_PRELUDE -xs !! n | n < 0 = error "Prelude.!!: negative index" -[] !! _ = error "Prelude.!!: index too large" +xs !! n | n < 0 = errorWithoutStackTrace "Prelude.!!: negative index" +[] !! _ = errorWithoutStackTrace "Prelude.!!: index too large" (x:_) !! 0 = x (_:xs) !! n = xs !! (n-1) #else @@ -864,10 +852,10 @@ -- if so we should be careful not to trip up known-bottom -- optimizations. tooLarge :: Int -> a -tooLarge _ = error (prel_list_str ++ "!!: index too large") +tooLarge _ = errorWithoutStackTrace (prel_list_str ++ "!!: index too large") negIndex :: a -negIndex = error $ prel_list_str ++ "!!: negative index" +negIndex = errorWithoutStackTrace $ prel_list_str ++ "!!: negative index" {-# INLINABLE (!!) #-} xs !! n @@ -1008,7 +996,7 @@ errorEmptyList :: String -> a errorEmptyList fun = - error (prel_list_str ++ fun ++ ": empty list") + errorWithoutStackTrace (prel_list_str ++ fun ++ ": empty list") prel_list_str :: String prel_list_str = "Prelude." diff --git a/GHC/MVar.hs b/GHC/MVar.hs --- a/GHC/MVar.hs +++ b/GHC/MVar.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Unsafe #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, AutoDeriveTypeable #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} @@ -33,9 +33,8 @@ ) where import GHC.Base -import Data.Typeable -data MVar a = MVar (MVar# RealWorld a) deriving( Typeable ) +data MVar a = MVar (MVar# RealWorld a) {- ^ An 'MVar' (pronounced \"em-var\") is a synchronising variable, used for communication between concurrent threads. It can be thought of @@ -177,6 +176,6 @@ -- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and -- "System.Mem.Weak" for more about finalizers. addMVarFinalizer :: MVar a -> IO () -> IO () -addMVarFinalizer (MVar m) finalizer = - IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } +addMVarFinalizer (MVar m) (IO finalizer) = + IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } diff --git a/GHC/Natural.hs b/GHC/Natural.hs --- a/GHC/Natural.hs +++ b/GHC/Natural.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -216,7 +215,7 @@ fromEnum (NatS# w) | i >= 0 = i where i = fromIntegral (W# w) - fromEnum _ = error "fromEnum: out of Int range" + fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" enumFrom x = enumDeltaNatural x (NatS# 1##) enumFromThen x y @@ -305,10 +304,10 @@ NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - complement _ = error "Bits.complement: Natural complement undefined" + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" bitSizeMaybe _ = Nothing - bitSize = error "Natural: bitSize" + bitSize = errorWithoutStackTrace "Natural: bitSize" isSigned _ = False bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) @@ -397,13 +396,6 @@ where res = minusBigNat x y --- | Helper for 'minusNatural' and 'minusNaturalMaybe' -subWordC# :: Word# -> Word# -> (# Word#, Int# #) -subWordC# x# y# = (# d#, c# #) - where - d# = x# `minusWord#` y# - c# = d# `gtWord#` x# - -- | Convert 'BigNat' to 'Natural'. -- Throws 'Underflow' if passed a 'nullBigNat'. bigNatToNatural :: BigNat -> Natural @@ -492,7 +484,7 @@ {-# INLINE (.|.) #-} xor (Natural n) (Natural m) = Natural (xor n m) {-# INLINE xor #-} - complement _ = error "Bits.complement: Natural complement undefined" + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" {-# INLINE complement #-} shift (Natural n) = Natural . shift n {-# INLINE shift #-} @@ -510,7 +502,7 @@ {-# INLINE testBit #-} bitSizeMaybe _ = Nothing {-# INLINE bitSizeMaybe #-} - bitSize = error "Natural: bitSize" + bitSize = errorWithoutStackTrace "Natural: bitSize" {-# INLINE bitSize #-} isSigned _ = False {-# INLINE isSigned #-} @@ -531,14 +523,14 @@ {-# INLINE toRational #-} instance Enum Natural where - pred (Natural 0) = error "Natural.pred: 0" + 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 = error "Natural.toEnum: negative" + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" | otherwise = Natural (toEnum n) {-# INLINE toEnum #-} @@ -605,7 +597,7 @@ toConstr x = mkIntegralConstr naturalType x gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Natural" dataTypeOf _ = naturalType diff --git a/GHC/OverloadedLabels.hs b/GHC/OverloadedLabels.hs new file mode 100644 --- /dev/null +++ b/GHC/OverloadedLabels.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude + , MultiParamTypeClasses + , MagicHash + , KindSignatures + , DataKinds + #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.OverloadedLabels +-- Copyright : (c) Adam Gundry 2015 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- This module defines the `IsLabel` class is used by the +-- OverloadedLabels extension. See the +-- +-- for more details. +-- +-- The key idea is that when GHC sees an occurrence of the new +-- overloaded label syntax @#foo@, it is replaced with +-- +-- > fromLabel (proxy# :: Proxy# "foo") :: alpha +-- +-- plus a wanted constraint @IsLabel "foo" alpha@. +-- +----------------------------------------------------------------------------- + +-- Note [Overloaded labels] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- An overloaded label is represented by the 'HsOverLabel' constructor +-- of 'HsExpr', which stores a 'FastString'. It is passed through +-- unchanged by the renamer, and the type-checker transforms it into a +-- call to 'fromLabel'. See Note [Type-checking overloaded labels] in +-- TcExpr for more details in how type-checking works. + +module GHC.OverloadedLabels + ( IsLabel(..) + ) where + +import GHC.Base ( Symbol ) +import GHC.Exts ( Proxy# ) + +class IsLabel (x :: Symbol) a where + fromLabel :: Proxy# x -> a diff --git a/GHC/Pack.hs b/GHC/Pack.hs --- a/GHC/Pack.hs +++ b/GHC/Pack.hs @@ -89,7 +89,7 @@ case (newByteArray# size s) of { (# s2#, barr# #) -> (# s2#, MutableByteArray bot bot barr# #) } where - bot = error "new_ps_array" + bot = errorWithoutStackTrace "new_ps_array" write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# -> case writeCharArray# barr# n ch s# of { s2# -> diff --git a/GHC/RTS/Flags.hsc b/GHC/RTS/Flags.hsc --- a/GHC/RTS/Flags.hsc +++ b/GHC/RTS/Flags.hsc @@ -87,7 +87,7 @@ toEnum #{const ONELINE_GC_STATS} = OneLineGCStats toEnum #{const SUMMARY_GC_STATS} = SummaryGCStats toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats - toEnum e = error ("invalid enum for GiveGCStats: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for GiveGCStats: " ++ show e) -- | Parameters of the garbage collector. -- @@ -185,7 +185,7 @@ toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose toEnum #{const COST_CENTRES_ALL} = CostCentresAll toEnum #{const COST_CENTRES_XML} = CostCentresXML - toEnum e = error ("invalid enum for DoCostCentres: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for DoCostCentres: " ++ show e) -- | Parameters pertaining to the cost-center profiler. -- @@ -228,7 +228,7 @@ toEnum #{const HEAP_BY_RETAINER} = HeapByRetainer toEnum #{const HEAP_BY_LDV} = HeapByLDV toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType - toEnum e = error ("invalid enum for DoHeapProfile: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for DoHeapProfile: " ++ show e) -- | Parameters of the cost-center profiler -- @@ -267,7 +267,7 @@ toEnum #{const TRACE_NONE} = TraceNone toEnum #{const TRACE_EVENTLOG} = TraceEventLog toEnum #{const TRACE_STDERR} = TraceStderr - toEnum e = error ("invalid enum for DoTrace: " ++ show e) + toEnum e = errorWithoutStackTrace ("invalid enum for DoTrace: " ++ show e) -- | Parameters pertaining to event tracing -- diff --git a/GHC/Read.hs b/GHC/Read.hs --- a/GHC/Read.hs +++ b/GHC/Read.hs @@ -59,7 +59,7 @@ import Data.Maybe -import GHC.Unicode ( isDigit ) +import GHC.Unicode import GHC.Num import GHC.Real import GHC.Float @@ -311,6 +311,8 @@ -------------------------------------------------------------- -- Simple instances of Read -------------------------------------------------------------- + +deriving instance Read GeneralCategory instance Read Char where readPrec = diff --git a/GHC/Real.hs b/GHC/Real.hs --- a/GHC/Real.hs +++ b/GHC/Real.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -91,12 +91,12 @@ -- | Extract the numerator of the ratio in reduced form: -- the numerator and denominator have no common factor and the denominator -- is positive. -numerator :: (Integral a) => Ratio a -> a +numerator :: Ratio a -> a -- | Extract the denominator of the ratio in reduced form: -- the numerator and denominator have no common factor and the denominator -- is positive. -denominator :: (Integral a) => Ratio a -> a +denominator :: Ratio a -> a -- | 'reduce' is a subsidiary function used only in this module. @@ -205,7 +205,7 @@ -1 -> n 0 -> if even n then n else m 1 -> m - _ -> error "round default defn: Bad value" + _ -> errorWithoutStackTrace "round default defn: Bad value" ceiling x = if r > 0 then n + 1 else n where (n,r) = properFraction x @@ -398,7 +398,7 @@ properFraction (x:%y) = (fromInteger (toInteger q), r:%y) where (q,r) = quotRem x y -instance (Integral a, Show a) => Show (Ratio a) where +instance (Show a) => Show (Ratio a) where {-# SPECIALIZE instance Show Rational #-} showsPrec p (x:%y) = showParen (p > ratioPrec) $ showsPrec ratioPrec1 x . @@ -463,10 +463,8 @@ even, odd :: (Integral a) => a -> Bool even n = n `rem` 2 == 0 odd = not . even -{-# SPECIALISE even :: Int -> Bool #-} -{-# SPECIALISE odd :: Int -> Bool #-} -{-# SPECIALISE even :: Integer -> Bool #-} -{-# SPECIALISE odd :: Integer -> Bool #-} +{-# INLINEABLE even #-} +{-# INLINEABLE odd #-} ------------------------------------------------------- -- | raise a number to a non-negative integral power @@ -476,7 +474,7 @@ Int -> Int -> Int #-} {-# INLINABLE [1] (^) #-} -- See Note [Inlining (^)] (^) :: (Num a, Integral b) => a -> b -> a -x0 ^ y0 | y0 < 0 = error "Negative exponent" +x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent" | y0 == 0 = 1 | otherwise = f x0 y0 where -- f : x0 ^ y0 = x ^ y @@ -585,7 +583,7 @@ {-# RULES "(^)/Rational" (^) = (^%^) #-} (^%^) :: Integral a => Rational -> a -> Rational (n :% d) ^%^ e - | e < 0 = error "Negative exponent" + | e < 0 = errorWithoutStackTrace "Negative exponent" | e == 0 = 1 :% 1 | otherwise = (n ^ e) :% (d ^ e) 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, runSTRep, + fixST, runST, -- * Unsafe functions liftST, unsafeInterleaveST @@ -58,16 +58,15 @@ (# 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 #) -> @@ -104,62 +103,10 @@ showsPrec _ _ = showString "<>" showList = showList__ (showsPrec 0) -{- -Definition of runST -~~~~~~~~~~~~~~~~~~~ - -SLPJ 95/04: Why @runST@ must not have an unfolding; consider: -\begin{verbatim} -f x = - runST ( \ s -> let - (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' ) -\end{verbatim} -If we inline @runST@, we'll get: -\begin{verbatim} -f x = let - (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' -\end{verbatim} -And now the @newArray#@ binding can be floated to become a CAF, which -is totally and utterly wrong: -\begin{verbatim} -f = let - (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in - \ x -> - let (_, s'') = fill_in_array_or_something a x s' in - freezeArray# a s'' -\end{verbatim} -All calls to @f@ will share a {\em single} array! End SLPJ 95/04. --} - {-# INLINE runST #-} --- The INLINE prevents runSTRep getting inlined in *this* module --- so that it is still visible when runST is inlined in an importing --- module. Regrettably delicate. runST is behaving like a wrapper. - -- | Return the value computed by a state transformer computation. -- The @forall@ ensures that the internal state used by the 'ST' -- computation is inaccessible to the rest of the program. runST :: (forall s. ST s a) -> a -runST st = runSTRep (case st of { ST st_rep -> st_rep }) - --- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness --- That's what the "INLINE [0]" says. --- SLPJ Apr 99 --- {-# INLINE [0] runSTRep #-} - --- SDM: further to the above, inline phase 0 is run *before* --- full-laziness at the moment, which means that the above comment is --- invalid. Inlining runSTRep doesn't make a huge amount of --- difference, anyway. Hence: - -{-# NOINLINE runSTRep #-} -runSTRep :: (forall s. STRep s a) -> a -runSTRep st_rep = case st_rep realWorld# of - (# _, r #) -> r +runST (ST st_rep) = case runRW# st_rep of (# _, a #) -> a +-- See Note [Definition of runRW#] in GHC.Magic diff --git a/GHC/Show.hs b/GHC/Show.hs --- a/GHC/Show.hs +++ b/GHC/Show.hs @@ -50,8 +50,9 @@ where import GHC.Base -import GHC.Num import GHC.List ((!!), foldr1, break) +import GHC.Num +import GHC.Stack.Types -- | The @shows@ functions return a function that prepends the -- output 'String' to an existing 'String'. This allows constant-time @@ -194,6 +195,21 @@ deriving instance Show a => Show (Maybe a) +instance Show TyCon where + showsPrec p (TyCon _ _ _ tc_name) = showsPrec p tc_name + +instance Show TrName where + showsPrec _ (TrNameS s) = showString (unpackCString# s) + showsPrec _ (TrNameD s) = showString s + +instance Show Module where + showsPrec _ (Module p m) = shows p . (':' :) . shows m + +instance Show CallStack where + showsPrec _ = shows . getCallStack + +deriving instance Show SrcLoc + -------------------------------------------------------------- -- Show instances for the first few tuple -------------------------------------------------------------- @@ -386,7 +402,7 @@ intToDigit (I# i) | isTrue# (i >=# 0#) && isTrue# (i <=# 9#) = unsafeChr (ord '0' + I# i) | isTrue# (i >=# 10#) && isTrue# (i <=# 15#) = unsafeChr (ord 'a' + I# i - 10) - | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i)) + | otherwise = errorWithoutStackTrace ("Char.intToDigit: not a digit " ++ show (I# i)) showSignedInt :: Int -> Int -> ShowS showSignedInt (I# p) (I# n) r @@ -454,7 +470,7 @@ (# q, r #) -> if q > 0 then q : r : jsplitb p ns else r : jsplitb p ns - jsplith _ [] = error "jsplith: []" + jsplith _ [] = errorWithoutStackTrace "jsplith: []" jsplitb :: Integer -> [Integer] -> [Integer] jsplitb _ [] = [] @@ -473,7 +489,7 @@ r = fromInteger r' in if q > 0 then jhead q $ jblock r $ jprintb ns cs else jhead r $ jprintb ns cs - jprinth [] _ = error "jprinth []" + jprinth [] _ = errorWithoutStackTrace "jprinth []" jprintb :: [Integer] -> String -> String jprintb [] cs = cs diff --git a/GHC/SrcLoc.hs b/GHC/SrcLoc.hs deleted file mode 100644 --- a/GHC/SrcLoc.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module GHC.SrcLoc - ( SrcLoc - , srcLocPackage - , srcLocModule - , srcLocFile - , srcLocStartLine - , srcLocStartCol - , srcLocEndLine - , srcLocEndCol - - -- * Pretty printing - , showSrcLoc - ) where - --- | A single location in the source code. -data SrcLoc = SrcLoc - { srcLocPackage :: String - , srcLocModule :: String - , srcLocFile :: String - , srcLocStartLine :: Int - , srcLocStartCol :: Int - , srcLocEndLine :: Int - , srcLocEndCol :: Int - } deriving (Show, Eq) - -showSrcLoc :: SrcLoc -> String -showSrcLoc SrcLoc {..} - = concat [ srcLocFile, ":" - , show srcLocStartLine, ":" - , show srcLocStartCol, " in " - , srcLocPackage, ":", srcLocModule - ] diff --git a/GHC/Stable.hs b/GHC/Stable.hs --- a/GHC/Stable.hs +++ b/GHC/Stable.hs @@ -1,6 +1,5 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude - , DeriveDataTypeable , MagicHash , UnboxedTuples #-} @@ -31,7 +30,6 @@ import GHC.Ptr import GHC.Base -import Data.Typeable.Internal ----------------------------------------------------------------------------- -- Stable Pointers @@ -48,7 +46,6 @@ expression of type @a@. -} data {-# CTYPE "HsStablePtr" #-} StablePtr a = StablePtr (StablePtr# a) - deriving( Typeable ) -- | -- Create a stable pointer referring to the given Haskell value. diff --git a/GHC/Stack.hs b/GHC/Stack.hs new file mode 100644 --- /dev/null +++ b/GHC/Stack.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Stack +-- Copyright : (c) The University of Glasgow 2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Access to GHC's call-stack simulation +-- +-- @since 4.5.0.0 +----------------------------------------------------------------------------- + +{-# LANGUAGE MagicHash, NoImplicitPrelude, ImplicitParams, RankNTypes #-} +module GHC.Stack ( + errorWithStackTrace, + + -- * Profiling call stacks + currentCallStack, + whoCreated, + + -- * HasCallStack call stacks + CallStack, HasCallStack, callStack, emptyCallStack, freezeCallStack, + fromCallSiteList, getCallStack, popCallStack, prettyCallStack, + pushCallStack, withFrozenCallStack, + + -- * Source locations + SrcLoc(..), prettySrcLoc, + + -- * Internals + CostCentreStack, + CostCentre, + getCurrentCCS, + getCCSOf, + clearCCS, + ccsCC, + ccsParent, + ccLabel, + ccModule, + ccSrcSpan, + ccsToStrings, + renderStack + ) where + +import GHC.Stack.CCS +import GHC.Stack.Types +import GHC.IO +import GHC.Base +import GHC.List +import GHC.Exception + +-- | Like the function 'error', but appends a stack trace to the error +-- message if one is available. +-- +-- @since 4.7.0.0 +{-# DEPRECATED errorWithStackTrace "'error' appends the call stack now" #-} + -- DEPRECATED in 8.0.1 +errorWithStackTrace :: String -> a +errorWithStackTrace x = unsafeDupablePerformIO $ do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwIO (ErrorCall x) + else throwIO (ErrorCallWithLocation x (renderStack stack)) + + +-- | Pop the most recent call-site off the 'CallStack'. +-- +-- This function, like 'pushCallStack', has no effect on a frozen 'CallStack'. +-- +-- @since 4.9.0.0 +popCallStack :: CallStack -> CallStack +popCallStack stk = case stk of + EmptyCallStack -> errorWithoutStackTrace "popCallStack: empty stack" + PushCallStack _ _ stk' -> stk' + FreezeCallStack _ -> stk +{-# INLINE popCallStack #-} + +-- | Return the current 'CallStack'. +-- +-- Does *not* include the call-site of 'callStack'. +-- +-- @since 4.9.0.0 +callStack :: HasCallStack => CallStack +callStack = popCallStack ?callStack +{-# INLINE callStack #-} + +-- | Perform some computation without adding new entries to the 'CallStack'. +-- +-- @since 4.9.0.0 +withFrozenCallStack :: HasCallStack + => ( HasCallStack => a ) + -> a +withFrozenCallStack do_this = + -- we pop the stack before freezing it to remove + -- withFrozenCallStack's call-site + let ?callStack = freezeCallStack (popCallStack callStack) + in do_this diff --git a/GHC/Stack.hsc b/GHC/Stack.hsc deleted file mode 100644 --- a/GHC/Stack.hsc +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Stack --- Copyright : (c) The University of Glasgow 2011 --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Access to GHC's call-stack simulation --- --- @since 4.5.0.0 ------------------------------------------------------------------------------ - -{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-} -module GHC.Stack ( - -- * Call stacks - -- ** Simulated by the RTS - currentCallStack, - whoCreated, - errorWithStackTrace, - - -- ** Explicitly created via implicit-parameters - CallStack, - getCallStack, - showCallStack, - - -- * Internals - CostCentreStack, - CostCentre, - getCurrentCCS, - getCCSOf, - ccsCC, - ccsParent, - ccLabel, - ccModule, - ccSrcSpan, - ccsToStrings, - renderStack - ) where - -import Data.List ( unlines ) - -import Foreign -import Foreign.C - -import GHC.IO -import GHC.Base -import GHC.Ptr -import GHC.Foreign as GHC -import GHC.IO.Encoding -import GHC.Exception -import GHC.List ( concatMap, null, reverse ) -import GHC.Show -import GHC.SrcLoc - -#define PROFILING -#include "Rts.h" - -data CostCentreStack -data CostCentre - -getCurrentCCS :: dummy -> IO (Ptr CostCentreStack) -getCurrentCCS dummy = IO $ \s -> - case getCurrentCCS## dummy s of - (## s', addr ##) -> (## s', Ptr addr ##) - -getCCSOf :: a -> IO (Ptr CostCentreStack) -getCCSOf obj = IO $ \s -> - case getCCSOf## obj s of - (## s', addr ##) -> (## s', Ptr addr ##) - -ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) -ccsCC p = (# peek CostCentreStack, cc) p - -ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack) -ccsParent p = (# peek CostCentreStack, prevStack) p - -ccLabel :: Ptr CostCentre -> IO CString -ccLabel p = (# peek CostCentre, label) p - -ccModule :: Ptr CostCentre -> IO CString -ccModule p = (# peek CostCentre, module) p - -ccSrcSpan :: Ptr CostCentre -> IO CString -ccSrcSpan p = (# peek CostCentre, srcloc) p - --- | returns a '[String]' representing the current call stack. This --- can be useful for debugging. --- --- The implementation uses the call-stack simulation maintined by the --- profiler, so it only works if the program was compiled with @-prof@ --- and contains suitable SCC annotations (e.g. by using @-fprof-auto@). --- Otherwise, the list returned is likely to be empty or --- uninformative. --- --- @since 4.5.0.0 - -currentCallStack :: IO [String] -currentCallStack = ccsToStrings =<< getCurrentCCS () - -ccsToStrings :: Ptr CostCentreStack -> IO [String] -ccsToStrings ccs0 = go ccs0 [] - where - go ccs acc - | ccs == nullPtr = return acc - | otherwise = do - cc <- ccsCC ccs - lbl <- GHC.peekCString utf8 =<< ccLabel cc - mdl <- GHC.peekCString utf8 =<< ccModule cc - loc <- GHC.peekCString utf8 =<< ccSrcSpan cc - parent <- ccsParent ccs - if (mdl == "MAIN" && lbl == "MAIN") - then return acc - else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc) - --- | Get the stack trace attached to an object. --- --- @since 4.5.0.0 -whoCreated :: a -> IO [String] -whoCreated obj = do - ccs <- getCCSOf obj - ccsToStrings ccs - -renderStack :: [String] -> String -renderStack strs = "Stack trace:" ++ concatMap ("\n "++) (reverse strs) - --- | Like the function 'error', but appends a stack trace to the error --- message if one is available. --- --- @since 4.7.0.0 -errorWithStackTrace :: String -> a -errorWithStackTrace x = unsafeDupablePerformIO $ do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwIO (ErrorCall x) - else throwIO (ErrorCall (x ++ '\n' : renderStack stack)) - - ----------------------------------------------------------------------- --- 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 --- ?loc, called at MyError.hs:7:51 in main:MyError --- myerror, called at :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. --- --- The @CallStack@ type is abstract, but it can be converted into a --- @[(String, SrcLoc)]@ via 'getCallStack'. 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.9.0.0 -data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] } - -- See Note [Overview of implicit CallStacks] - deriving (Show, Eq) - -showCallStack :: CallStack -> String -showCallStack (CallStack (root:rest)) - = unlines (showCallSite root : map (indent . showCallSite) rest) - where - indent l = " " ++ l - showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc -showCallStack _ = error "CallStack cannot be empty!" diff --git a/GHC/Stack/CCS.hs-boot b/GHC/Stack/CCS.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Stack/CCS.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module GHC.Stack.CCS where + +{- Cuts the following loop: + + GHC.Exception.errorCallWithCallStackException requires + GHC.Stack.CCS.currentCallStack, which requires + Foreign.C (for peeking CostCentres) + GHC.Foreign, GHC.IO.Encoding (for decoding UTF-8 strings) + .. lots of stuff ... + GHC.Exception +-} + +import GHC.Base + +currentCallStack :: IO [String] diff --git a/GHC/Stack/CCS.hsc b/GHC/Stack/CCS.hsc new file mode 100644 --- /dev/null +++ b/GHC/Stack/CCS.hsc @@ -0,0 +1,120 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Stack.CCS +-- Copyright : (c) The University of Glasgow 2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Access to GHC's call-stack simulation +-- +-- @since 4.5.0.0 +----------------------------------------------------------------------------- + +{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-} +module GHC.Stack.CCS ( + -- * Call stacks + currentCallStack, + whoCreated, + + -- * Internals + CostCentreStack, + CostCentre, + getCurrentCCS, + getCCSOf, + clearCCS, + ccsCC, + ccsParent, + ccLabel, + ccModule, + ccSrcSpan, + ccsToStrings, + renderStack + ) where + +import Foreign +import Foreign.C + +import GHC.Base +import GHC.Ptr +import GHC.Foreign as GHC +import GHC.IO.Encoding +import GHC.List ( concatMap, reverse ) + +#define PROFILING +#include "Rts.h" + +data CostCentreStack +data CostCentre + +getCurrentCCS :: dummy -> IO (Ptr CostCentreStack) +getCurrentCCS dummy = IO $ \s -> + case getCurrentCCS## dummy s of + (## s', addr ##) -> (## s', Ptr addr ##) + +getCCSOf :: a -> IO (Ptr CostCentreStack) +getCCSOf obj = IO $ \s -> + case getCCSOf## obj s of + (## s', addr ##) -> (## s', Ptr addr ##) + +clearCCS :: IO a -> IO a +clearCCS (IO m) = IO $ \s -> clearCCS## m s + +ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) +ccsCC p = (# peek CostCentreStack, cc) p + +ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack) +ccsParent p = (# peek CostCentreStack, prevStack) p + +ccLabel :: Ptr CostCentre -> IO CString +ccLabel p = (# peek CostCentre, label) p + +ccModule :: Ptr CostCentre -> IO CString +ccModule p = (# peek CostCentre, module) p + +ccSrcSpan :: Ptr CostCentre -> IO CString +ccSrcSpan p = (# peek CostCentre, srcloc) p + +-- | Returns a @[String]@ representing the current call stack. This +-- can be useful for debugging. +-- +-- The implementation uses the call-stack simulation maintined by the +-- profiler, so it only works if the program was compiled with @-prof@ +-- and contains suitable SCC annotations (e.g. by using @-fprof-auto@). +-- Otherwise, the list returned is likely to be empty or +-- uninformative. +-- +-- @since 4.5.0.0 +currentCallStack :: IO [String] +currentCallStack = ccsToStrings =<< getCurrentCCS () + +ccsToStrings :: Ptr CostCentreStack -> IO [String] +ccsToStrings ccs0 = go ccs0 [] + where + go ccs acc + | ccs == nullPtr = return acc + | otherwise = do + cc <- ccsCC ccs + lbl <- GHC.peekCString utf8 =<< ccLabel cc + mdl <- GHC.peekCString utf8 =<< ccModule cc + loc <- GHC.peekCString utf8 =<< ccSrcSpan cc + parent <- ccsParent ccs + if (mdl == "MAIN" && lbl == "MAIN") + then return acc + else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc) + +-- | Get the stack trace attached to an object. +-- +-- @since 4.5.0.0 +whoCreated :: a -> IO [String] +whoCreated obj = do + ccs <- getCCSOf obj + ccsToStrings ccs + +renderStack :: [String] -> String +renderStack strs = + "CallStack (from -prof):" ++ concatMap ("\n "++) (reverse strs) diff --git a/GHC/Stack/Types.hs b/GHC/Stack/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Stack/Types.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK hide #-} +-- we hide this module from haddock to enforce GHC.Stack as the main +-- access point. + +----------------------------------------------------------------------------- +-- | +-- 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 implicit call-stacks. +-- Use "GHC.Stack" from the base package instead of importing this +-- module directly. +-- +----------------------------------------------------------------------------- + +module GHC.Stack.Types ( + -- * Implicit call stacks + CallStack(..), HasCallStack, + emptyCallStack, freezeCallStack, fromCallSiteList, + getCallStack, pushCallStack, + + -- * Source locations + SrcLoc(..) + ) where + +{- +Ideally these would live in GHC.Stack but sadly they can't due to this +import cycle, + + Module imports form a cycle: + module ‘Data.Maybe’ (libraries/base/Data/Maybe.hs) + imports ‘GHC.Base’ (libraries/base/GHC/Base.hs) + which imports ‘GHC.Err’ (libraries/base/GHC/Err.hs) + which imports ‘GHC.Stack’ (libraries/base/dist-install/build/GHC/Stack.hs) + which imports ‘GHC.Foreign’ (libraries/base/GHC/Foreign.hs) + which imports ‘Data.Maybe’ (libraries/base/Data/Maybe.hs) +-} + +import GHC.Classes (Eq) +import GHC.Types (Char, Int) + +-- Make implicit dependency known to build system +import GHC.Tuple () +import GHC.Integer () + +---------------------------------------------------------------------- +-- Explicit call-stacks built via ImplicitParams +---------------------------------------------------------------------- + +-- | Request a CallStack. +-- +-- NOTE: The implicit parameter @?callStack :: CallStack@ is an +-- implementation detail and __should not__ be considered part of the +-- 'CallStack' API, we may decide to change the implementation in the +-- future. +-- +-- @since 4.9.0.0 +type HasCallStack = (?callStack :: CallStack) + +-- | 'CallStack's are a lightweight method of obtaining a +-- partial call-stack at any point in the program. +-- +-- A function can request its call-site with the 'HasCallStack' constraint. +-- For example, we can define +-- +-- @ +-- errorWithCallStack :: HasCallStack => String -> a +-- @ +-- +-- as a variant of @error@ that will get its call-site. We can access the +-- call-stack inside @errorWithCallStack@ with 'GHC.Stack.callStack'. +-- +-- @ +-- errorWithCallStack :: HasCallStack => String -> a +-- errorWithCallStack msg = error (msg ++ "\n" ++ prettyCallStack callStack) +-- @ +-- +-- Thus, if we call @errorWithCallStack@ we will get a formatted call-stack +-- alongside our error message. +-- +-- +-- >>> errorWithCallStack "die" +-- *** Exception: die +-- CallStack (from HasCallStack): +-- errorWithCallStack, called at :2:1 in interactive:Ghci1 +-- +-- +-- GHC solves 'HasCallStack' constraints in three steps: +-- +-- 1. If there is a 'CallStack' in scope -- i.e. the enclosing function +-- has a 'HasCallStack' constraint -- GHC will append the new +-- call-site to the existing 'CallStack'. +-- +-- 2. If there is no 'CallStack' in scope -- e.g. in the GHCi session +-- above -- and the enclosing definition does not have an explicit +-- type signature, GHC will infer a 'HasCallStack' constraint for the +-- enclosing definition (subject to the monomorphism restriction). +-- +-- 3. If there is no 'CallStack' in scope and the enclosing definition +-- has an explicit type signature, GHC will solve the 'HasCallStack' +-- constraint for the singleton 'CallStack' containing just the +-- current call-site. +-- +-- '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 via the +-- 'HasCallStack' constraints, 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. +-- +-- NOTE: The intrepid user may notice that 'HasCallStack' is just an +-- alias for an implicit parameter @?callStack :: CallStack@. This is an +-- implementation detail and __should not__ be considered part of the +-- 'CallStack' API, we may decide to change the implementation in the +-- future. +-- +-- @since 4.8.1.0 +data CallStack + = EmptyCallStack + | PushCallStack [Char] SrcLoc CallStack + | FreezeCallStack CallStack + -- ^ Freeze the stack at the given @CallStack@, preventing any further + -- call-sites from being pushed onto it. + + -- See Note [Overview of implicit CallStacks] + +-- | Extract a list of call-sites from the 'CallStack'. +-- +-- The list is ordered by most recent call. +-- +-- @since 4.8.1.0 +getCallStack :: CallStack -> [([Char], SrcLoc)] +getCallStack stk = case stk of + EmptyCallStack -> [] + PushCallStack fn loc stk' -> (fn,loc) : getCallStack stk' + FreezeCallStack stk' -> getCallStack stk' + +-- | Convert a list of call-sites to a 'CallStack'. +-- +-- @since 4.9.0.0 +fromCallSiteList :: [([Char], SrcLoc)] -> CallStack +fromCallSiteList ((fn,loc):cs) = PushCallStack fn loc (fromCallSiteList cs) +fromCallSiteList [] = EmptyCallStack + +-- Note [Definition of CallStack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- CallStack is defined very early in base because it is +-- used by error and undefined. At this point in the dependency graph, +-- we do not have enough functionality to (conveniently) write a nice +-- pretty-printer for CallStack. The sensible place to define the +-- pretty-printer would be GHC.Stack, which is the main access point, +-- but unfortunately GHC.Stack imports GHC.Exception, which *needs* +-- the pretty-printer. So the CallStack type and functions are split +-- between three modules: +-- +-- 1. GHC.Stack.Types: defines the type and *simple* functions +-- 2. GHC.Exception: defines the pretty-printer +-- 3. GHC.Stack: exports everything and acts as the main access point + + +-- | Push a call-site onto the stack. +-- +-- This function has no effect on a frozen 'CallStack'. +-- +-- @since 4.9.0.0 +pushCallStack :: ([Char], SrcLoc) -> CallStack -> CallStack +pushCallStack (fn, loc) stk = case stk of + FreezeCallStack _ -> stk + _ -> PushCallStack fn loc stk +{-# INLINE pushCallStack #-} + + +-- | The empty 'CallStack'. +-- +-- @since 4.9.0.0 +emptyCallStack :: CallStack +emptyCallStack = EmptyCallStack +{-# INLINE emptyCallStack #-} + + +-- | Freeze a call-stack, preventing any further call-sites from being appended. +-- +-- prop> pushCallStack callSite (freezeCallStack callStack) = freezeCallStack callStack +-- +-- @since 4.9.0.0 +freezeCallStack :: CallStack -> CallStack +freezeCallStack stk = FreezeCallStack stk +{-# INLINE freezeCallStack #-} + + +-- | A single location in the source code. +-- +-- @since 4.8.1.0 +data SrcLoc = SrcLoc + { srcLocPackage :: [Char] + , srcLocModule :: [Char] + , srcLocFile :: [Char] + , srcLocStartLine :: Int + , srcLocStartCol :: Int + , srcLocEndLine :: Int + , srcLocEndCol :: Int + } deriving Eq diff --git a/GHC/StaticPtr.hs b/GHC/StaticPtr.hs --- a/GHC/StaticPtr.hs +++ b/GHC/StaticPtr.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ExistentialQuantification #-} @@ -39,9 +38,9 @@ , StaticPtrInfo(..) , staticPtrInfo , staticPtrKeys + , IsStatic(..) ) where -import Data.Typeable (Typeable) import Foreign.C.Types (CInt(..)) import Foreign.Marshal (allocaArray, peekArray, withArray) import Foreign.Ptr (castPtr) @@ -52,7 +51,6 @@ -- | A reference to a value of type 'a'. data StaticPtr a = StaticPtr StaticKey StaticPtrInfo a - deriving Typeable -- | Dereferences a static pointer. deRefStaticPtr :: StaticPtr a -> a @@ -83,10 +81,17 @@ foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a) +-- | A class for things buildable from static pointers. +class IsStatic p where + fromStaticPtr :: StaticPtr a -> p a + +instance IsStatic StaticPtr where + fromStaticPtr = id + -- | 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 @@ -96,7 +101,7 @@ -- @(Line, Column)@ pair. , spInfoSrcLoc :: (Int, Int) } - deriving (Show, Typeable) + deriving (Show) -- | '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 @@ -39,39 +39,58 @@ -- I'm probably violating a bucket of constraints here... oops. --- | Global garbage collection and memory statistics. +-- | Statistics about memory usage and the garbage collector. Apart from +-- 'currentBytesUsed' and 'currentBytesSlop' all are cumulative values since +-- the program started. -- -- @since 4.5.0.0 data GCStats = GCStats - { bytesAllocated :: !Int64 -- ^ Total number of bytes allocated - , numGcs :: !Int64 -- ^ Number of garbage collections performed - , maxBytesUsed :: !Int64 -- ^ Maximum number of live bytes seen so far - , numByteUsageSamples :: !Int64 -- ^ Number of byte usage samples taken + { -- | Total number of bytes allocated + bytesAllocated :: !Int64 + -- | Number of garbage collections performed (any generation, major and + -- minor) + , numGcs :: !Int64 + -- | Maximum number of live bytes seen so far + , maxBytesUsed :: !Int64 + -- | Number of byte usage samples taken, or equivalently + -- the number of major GCs performed. + , numByteUsageSamples :: !Int64 -- | Sum of all byte usage samples, can be used with -- 'numByteUsageSamples' to calculate averages with -- arbitrary weighting (if you are sampling this record multiple -- times). , cumulativeBytesUsed :: !Int64 - , bytesCopied :: !Int64 -- ^ Number of bytes copied during GC - , currentBytesUsed :: !Int64 -- ^ Current number of live bytes - , currentBytesSlop :: !Int64 -- ^ Current number of bytes lost to slop - , maxBytesSlop :: !Int64 -- ^ Maximum number of bytes lost to slop at any one time so far - , peakMegabytesAllocated :: !Int64 -- ^ Maximum number of megabytes allocated + -- | Number of bytes copied during GC + , bytesCopied :: !Int64 + -- | Number of live bytes at the end of the last major GC + , currentBytesUsed :: !Int64 + -- | Current number of bytes lost to slop + , currentBytesSlop :: !Int64 + -- | Maximum number of bytes lost to slop at any one time so far + , maxBytesSlop :: !Int64 + -- | Maximum number of megabytes allocated + , peakMegabytesAllocated :: !Int64 -- | CPU time spent running mutator threads. This does not include -- any profiling overhead or initialization. , mutatorCpuSeconds :: !Double + -- | Wall clock time spent running mutator threads. This does not -- include initialization. , mutatorWallSeconds :: !Double - , gcCpuSeconds :: !Double -- ^ CPU time spent running GC - , gcWallSeconds :: !Double -- ^ Wall clock time spent running GC - , cpuSeconds :: !Double -- ^ Total CPU time elapsed since program start - , wallSeconds :: !Double -- ^ Total wall clock time elapsed since start + -- | CPU time spent running GC + , gcCpuSeconds :: !Double + -- | Wall clock time spent running GC + , gcWallSeconds :: !Double + -- | Total CPU time elapsed since program start + , cpuSeconds :: !Double + -- | Total wall clock time elapsed since start + , wallSeconds :: !Double -- | Number of bytes copied during GC, minus space held by mutable -- lists held by the capabilities. Can be used with -- 'parMaxBytesCopied' to determine how well parallel GC utilized -- all cores. , parTotBytesCopied :: !Int64 + -- | Sum of number of bytes copied each GC by the most active GC -- thread each GC. The ratio of 'parTotBytesCopied' divided by -- 'parMaxBytesCopied' approaches 1 for a maximally sequential diff --git a/GHC/TypeLits.hs b/GHC/TypeLits.hs --- a/GHC/TypeLits.hs +++ b/GHC/TypeLits.hs @@ -12,6 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} -- for compiling instances of (==) {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface @@ -22,7 +23,7 @@ module GHC.TypeLits ( -- * Kinds - Nat, Symbol + Nat, Symbol -- Both declared in GHC.Types in package ghc-prim -- * Linking type and value level , KnownNat, natVal, natVal' @@ -36,9 +37,14 @@ , type (<=), type (<=?), type (+), type (*), type (^), type (-) , CmpNat, CmpSymbol + -- * User-defined type errors + , TypeError + , ErrorMessage(..) + ) where import GHC.Base(Eq(..), Ord(..), Bool(True,False), Ordering(..), otherwise) +import GHC.Types( Nat, Symbol ) import GHC.Num(Integer) import GHC.Base(String) import GHC.Show(Show(..)) @@ -49,13 +55,6 @@ import Data.Type.Equality(type (==), (:~:)(Refl)) import Unsafe.Coerce(unsafeCoerce) --- | (Kind) This is the kind of type-level natural numbers. -data Nat - --- | (Kind) This is the kind of type-level symbols. -data Symbol - - -------------------------------------------------------------------------------- -- | This class gives the integer associated with a type-level natural. @@ -197,6 +196,54 @@ type family (m :: Nat) - (n :: Nat) :: Nat +-- | A description of a custom type error. +data {-kind-} ErrorMessage = Text Symbol + -- ^ Show the text as is. + + | forall t. ShowType t + -- ^ Pretty print the type. + -- @ShowType :: k -> ErrorMessage@ + + | ErrorMessage :<>: ErrorMessage + -- ^ Put two pieces of error message next + -- to each other. + + | ErrorMessage :$$: ErrorMessage + -- ^ Stack two pieces of error message on top + -- of each other. + +infixl 5 :$$: +infixl 6 :<>: + +-- | The type-level equivalent of 'error'. +-- +-- The polymorphic kind of this type allows it to be used in several settings. +-- For instance, it can be used as a constraint, e.g. to provide a better error +-- message for a non-existant instance, +-- +-- @ +-- -- in a context +-- instance TypeError (Text "Cannot 'Show' functions." :$$: +-- Text "Perhaps there is a missing argument?") +-- => Show (a -> b) where +-- showsPrec = error "unreachable" +-- @ +-- +-- It can also be placed on the right-hand side of a type-level function +-- to provide an error for an invalid case, +-- +-- @ +-- type family ByteSize x where +-- ByteSize Word16 = 2 +-- ByteSize Word8 = 1 +-- ByteSize a = TypeError (Text "The type " :<>: ShowType a :<>: +-- Text " is not exportable.") +-- @ +-- +-- @since 4.9.0.0 +type family TypeError (a :: ErrorMessage) :: b where + + -------------------------------------------------------------------------------- -- | We either get evidence that this function was instantiated with the @@ -237,5 +284,3 @@ withSSymbol :: (KnownSymbol a => Proxy a -> b) -> SSymbol a -> Proxy a -> b withSSymbol f x y = magicDict (WrapS f) x y - - diff --git a/GHC/Unicode.hs b/GHC/Unicode.hs --- a/GHC/Unicode.hs +++ b/GHC/Unicode.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -19,11 +19,13 @@ ----------------------------------------------------------------------------- module GHC.Unicode ( + GeneralCategory (..), generalCategory, isAscii, isLatin1, isControl, isAsciiUpper, isAsciiLower, isPrint, isSpace, isUpper, isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, + isPunctuation, isSymbol, toUpper, toLower, toTitle, wgencat ) where @@ -31,10 +33,131 @@ import GHC.Base import GHC.Char (chr) import GHC.Real +import GHC.Enum ( Enum (..), Bounded (..) ) +import GHC.Arr ( Ix (..) ) import GHC.Num +-- Data.Char.chr already imports this and we need to define a Show instance +-- for GeneralCategory +import GHC.Show ( Show ) + #include "HsBaseConfig.h" +-- | Unicode General Categories (column 2 of the UnicodeData table) in +-- the order they are listed in the Unicode standard (the Unicode +-- Character Database, in particular). +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> :t OtherLetter +-- OtherLetter :: GeneralCategory +-- +-- 'Eq' instance: +-- +-- >>> UppercaseLetter == UppercaseLetter +-- True +-- >>> UppercaseLetter == LowercaseLetter +-- False +-- +-- 'Ord' instance: +-- +-- >>> NonSpacingMark <= MathSymbol +-- True +-- +-- 'Enum' instance: +-- +-- >>> enumFromTo ModifierLetter SpacingCombiningMark +-- [ModifierLetter,OtherLetter,NonSpacingMark,SpacingCombiningMark] +-- +-- 'Read' instance: +-- +-- >>> read "DashPunctuation" :: GeneralCategory +-- DashPunctuation +-- >>> read "17" :: GeneralCategory +-- *** Exception: Prelude.read: no parse +-- +-- 'Show' instance: +-- +-- >>> show EnclosingMark +-- "EnclosingMark" +-- +-- 'Bounded' instance: +-- +-- >>> minBound :: GeneralCategory +-- UppercaseLetter +-- >>> maxBound :: GeneralCategory +-- NotAssigned +-- +-- 'Ix' instance: +-- +-- >>> import Data.Ix ( index ) +-- >>> index (OtherLetter,Control) FinalQuote +-- 12 +-- >>> index (OtherLetter,Control) Format +-- *** Exception: Error in array index +-- +data GeneralCategory + = UppercaseLetter -- ^ Lu: Letter, Uppercase + | LowercaseLetter -- ^ Ll: Letter, Lowercase + | TitlecaseLetter -- ^ Lt: Letter, Titlecase + | ModifierLetter -- ^ Lm: Letter, Modifier + | OtherLetter -- ^ Lo: Letter, Other + | NonSpacingMark -- ^ Mn: Mark, Non-Spacing + | SpacingCombiningMark -- ^ Mc: Mark, Spacing Combining + | EnclosingMark -- ^ Me: Mark, Enclosing + | DecimalNumber -- ^ Nd: Number, Decimal + | LetterNumber -- ^ Nl: Number, Letter + | OtherNumber -- ^ No: Number, Other + | ConnectorPunctuation -- ^ Pc: Punctuation, Connector + | DashPunctuation -- ^ Pd: Punctuation, Dash + | OpenPunctuation -- ^ Ps: Punctuation, Open + | ClosePunctuation -- ^ Pe: Punctuation, Close + | InitialQuote -- ^ Pi: Punctuation, Initial quote + | FinalQuote -- ^ Pf: Punctuation, Final quote + | OtherPunctuation -- ^ Po: Punctuation, Other + | MathSymbol -- ^ Sm: Symbol, Math + | CurrencySymbol -- ^ Sc: Symbol, Currency + | ModifierSymbol -- ^ Sk: Symbol, Modifier + | OtherSymbol -- ^ So: Symbol, Other + | Space -- ^ Zs: Separator, Space + | LineSeparator -- ^ Zl: Separator, Line + | ParagraphSeparator -- ^ Zp: Separator, Paragraph + | Control -- ^ Cc: Other, Control + | Format -- ^ Cf: Other, Format + | Surrogate -- ^ Cs: Other, Surrogate + | PrivateUse -- ^ Co: Other, Private Use + | NotAssigned -- ^ Cn: Other, Not Assigned + deriving (Show, Eq, Ord, Enum, Bounded, Ix) + +-- | The Unicode general category of the character. This relies on the +-- 'Enum' instance of 'GeneralCategory', which must remain in the +-- same order as the categories are presented in the Unicode +-- standard. +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> generalCategory 'a' +-- LowercaseLetter +-- >>> generalCategory 'A' +-- UppercaseLetter +-- >>> generalCategory '0' +-- DecimalNumber +-- >>> generalCategory '%' +-- OtherPunctuation +-- >>> generalCategory '♥' +-- OtherSymbol +-- >>> generalCategory '\31' +-- Control +-- >>> generalCategory ' ' +-- Space +-- +generalCategory :: Char -> GeneralCategory +generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c + -- | Selects the first 128 characters of the Unicode character set, -- corresponding to the ASCII character set. isAscii :: Char -> Bool @@ -117,6 +240,96 @@ isHexDigit c = isDigit c || (fromIntegral (ord c - ord 'A')::Word) <= 5 || (fromIntegral (ord c - ord 'a')::Word) <= 5 + +-- | Selects Unicode punctuation characters, including various kinds +-- of connectors, brackets and quotes. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'ConnectorPunctuation' +-- * 'DashPunctuation' +-- * 'OpenPunctuation' +-- * 'ClosePunctuation' +-- * 'InitialQuote' +-- * 'FinalQuote' +-- * 'OtherPunctuation' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Punctuation\". +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isPunctuation 'a' +-- False +-- >>> isPunctuation '7' +-- False +-- >>> isPunctuation '♥' +-- False +-- >>> isPunctuation '"' +-- True +-- >>> isPunctuation '?' +-- True +-- >>> isPunctuation '—' +-- True +-- +isPunctuation :: Char -> Bool +isPunctuation c = case generalCategory c of + ConnectorPunctuation -> True + DashPunctuation -> True + OpenPunctuation -> True + ClosePunctuation -> True + InitialQuote -> True + FinalQuote -> True + OtherPunctuation -> True + _ -> False + +-- | Selects Unicode symbol characters, including mathematical and +-- currency symbols. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'MathSymbol' +-- * 'CurrencySymbol' +-- * 'ModifierSymbol' +-- * 'OtherSymbol' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Symbol\". +-- +-- ==== __Examples__ +-- +-- Basic usage: +-- +-- >>> isSymbol 'a' +-- False +-- >>> isSymbol '6' +-- False +-- >>> isSymbol '=' +-- True +-- +-- The definition of \"math symbol\" may be a little +-- counter-intuitive depending on one's background: +-- +-- >>> isSymbol '+' +-- True +-- >>> isSymbol '-' +-- False +-- +isSymbol :: Char -> Bool +isSymbol c = case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + _ -> False -- | Convert a letter to the corresponding upper-case letter, if any. -- Any other character is returned unchanged. diff --git a/GHC/Weak.hs b/GHC/Weak.hs --- a/GHC/Weak.hs +++ b/GHC/Weak.hs @@ -3,7 +3,6 @@ , BangPatterns , MagicHash , UnboxedTuples - , DeriveDataTypeable , StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} @@ -31,7 +30,6 @@ ) where import GHC.Base -import Data.Typeable {-| A weak pointer object with a key and a value. The value has type @v@. @@ -91,7 +89,7 @@ by the compiler. -} -data Weak v = Weak (Weak# v) deriving Typeable +data Weak v = Weak (Weak# v) -- | Establishes a weak pointer to @k@, with value @v@ and a finalizer. -- @@ -102,7 +100,7 @@ -> Maybe (IO ()) -- ^ finalizer -> IO (Weak v) -- ^ returns: a weak pointer object -mkWeak key val (Just finalizer) = IO $ \s -> +mkWeak key val (Just (IO finalizer)) = IO $ \s -> case mkWeak# key val finalizer s of { (# s1, w #) -> (# s1, Weak w #) } mkWeak key val Nothing = IO $ \s -> case mkWeakNoFinalizer# key val s of { (# s1, w #) -> (# s1, Weak w #) } @@ -143,14 +141,15 @@ -- the IO primitives are inlined by hand here to get the optimal -- code (sigh) --SDM. -runFinalizerBatch :: Int -> Array# (IO ()) -> IO () +runFinalizerBatch :: Int -> Array# (State# RealWorld -> State# RealWorld) + -> IO () runFinalizerBatch (I# n) arr = let go m = IO $ \s -> case m of 0# -> (# s, () #) _ -> let !m' = m -# 1# in case indexArray# arr m' of { (# io #) -> - case unIO io s of { (# s', _ #) -> + case io s of { s' -> unIO (go m') s' }} in diff --git a/GHC/Word.hs b/GHC/Word.hs --- a/GHC/Word.hs +++ b/GHC/Word.hs @@ -21,11 +21,23 @@ module GHC.Word ( Word(..), Word8(..), Word16(..), Word32(..), Word64(..), + + -- * Shifts uncheckedShiftL64#, uncheckedShiftRL64#, + + -- * Byte swapping byteSwap16, byteSwap32, - byteSwap64 + byteSwap64, + + -- * Equality operators + -- | See GHC.Classes#matching_overloaded_methods_in_rules + eqWord, neWord, gtWord, geWord, ltWord, leWord, + eqWord8, neWord8, gtWord8, geWord8, ltWord8, leWord8, + eqWord16, neWord16, gtWord16, geWord16, ltWord16, leWord16, + eqWord32, neWord32, gtWord32, geWord32, ltWord32, leWord32, + eqWord64, neWord64, gtWord64, geWord64, ltWord64, leWord64 ) where import Data.Bits @@ -50,9 +62,36 @@ -- Word8 is represented in the same way as Word. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsWord8" #-} Word8 = W8# Word# deriving (Eq, Ord) +data {-# CTYPE "HsWord8" #-} Word8 = W8# Word# -- ^ 8-bit unsigned integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Word8 where + (==) = eqWord8 + (/=) = neWord8 + +eqWord8, neWord8 :: Word8 -> Word8 -> Bool +eqWord8 (W8# x) (W8# y) = isTrue# (x `eqWord#` y) +neWord8 (W8# x) (W8# y) = isTrue# (x `neWord#` y) +{-# INLINE [1] eqWord8 #-} +{-# INLINE [1] neWord8 #-} + +instance Ord Word8 where + (<) = ltWord8 + (<=) = leWord8 + (>=) = geWord8 + (>) = gtWord8 + +{-# INLINE [1] gtWord8 #-} +{-# INLINE [1] geWord8 #-} +{-# INLINE [1] ltWord8 #-} +{-# INLINE [1] leWord8 #-} +gtWord8, geWord8, ltWord8, leWord8 :: Word8 -> Word8 -> Bool +(W8# x) `gtWord8` (W8# y) = isTrue# (x `gtWord#` y) +(W8# x) `geWord8` (W8# y) = isTrue# (x `geWord#` y) +(W8# x) `ltWord8` (W8# y) = isTrue# (x `ltWord#` y) +(W8# x) `leWord8` (W8# y) = isTrue# (x `leWord#` y) + instance Show Word8 where showsPrec p x = showsPrec p (fromIntegral x :: Int) @@ -199,9 +238,36 @@ -- Word16 is represented in the same way as Word. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsWord16" #-} Word16 = W16# Word# deriving (Eq, Ord) +data {-# CTYPE "HsWord16" #-} Word16 = W16# Word# -- ^ 16-bit unsigned integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Word16 where + (==) = eqWord16 + (/=) = neWord16 + +eqWord16, neWord16 :: Word16 -> Word16 -> Bool +eqWord16 (W16# x) (W16# y) = isTrue# (x `eqWord#` y) +neWord16 (W16# x) (W16# y) = isTrue# (x `neWord#` y) +{-# INLINE [1] eqWord16 #-} +{-# INLINE [1] neWord16 #-} + +instance Ord Word16 where + (<) = ltWord16 + (<=) = leWord16 + (>=) = geWord16 + (>) = gtWord16 + +{-# INLINE [1] gtWord16 #-} +{-# INLINE [1] geWord16 #-} +{-# INLINE [1] ltWord16 #-} +{-# INLINE [1] leWord16 #-} +gtWord16, geWord16, ltWord16, leWord16 :: Word16 -> Word16 -> Bool +(W16# x) `gtWord16` (W16# y) = isTrue# (x `gtWord#` y) +(W16# x) `geWord16` (W16# y) = isTrue# (x `geWord#` y) +(W16# x) `ltWord16` (W16# y) = isTrue# (x `ltWord#` y) +(W16# x) `leWord16` (W16# y) = isTrue# (x `leWord#` y) + instance Show Word16 where showsPrec p x = showsPrec p (fromIntegral x :: Int) @@ -391,9 +457,36 @@ #endif -data {-# CTYPE "HsWord32" #-} Word32 = W32# Word# deriving (Eq, Ord) +data {-# CTYPE "HsWord32" #-} Word32 = W32# Word# -- ^ 32-bit unsigned integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Word32 where + (==) = eqWord32 + (/=) = neWord32 + +eqWord32, neWord32 :: Word32 -> Word32 -> Bool +eqWord32 (W32# x) (W32# y) = isTrue# (x `eqWord#` y) +neWord32 (W32# x) (W32# y) = isTrue# (x `neWord#` y) +{-# INLINE [1] eqWord32 #-} +{-# INLINE [1] neWord32 #-} + +instance Ord Word32 where + (<) = ltWord32 + (<=) = leWord32 + (>=) = geWord32 + (>) = gtWord32 + +{-# INLINE [1] gtWord32 #-} +{-# INLINE [1] geWord32 #-} +{-# INLINE [1] ltWord32 #-} +{-# INLINE [1] leWord32 #-} +gtWord32, geWord32, ltWord32, leWord32 :: Word32 -> Word32 -> Bool +(W32# x) `gtWord32` (W32# y) = isTrue# (x `gtWord#` y) +(W32# x) `geWord32` (W32# y) = isTrue# (x `geWord#` y) +(W32# x) `ltWord32` (W32# y) = isTrue# (x `ltWord#` y) +(W32# x) `leWord32` (W32# y) = isTrue# (x `leWord#` y) + instance Num Word32 where (W32# x#) + (W32# y#) = W32# (narrow32Word# (x# `plusWord#` y#)) (W32# x#) - (W32# y#) = W32# (narrow32Word# (x# `minusWord#` y#)) @@ -551,16 +644,33 @@ data {-# CTYPE "HsWord64" #-} Word64 = W64# Word64# -- ^ 64-bit unsigned integer type +-- See GHC.Classes#matching_overloaded_methods_in_rules instance Eq Word64 where - (W64# x#) == (W64# y#) = isTrue# (x# `eqWord64#` y#) - (W64# x#) /= (W64# y#) = isTrue# (x# `neWord64#` y#) + (==) = eqWord64 + (/=) = neWord64 +eqWord64, neWord64 :: Word64 -> Word64 -> Bool +eqWord64 (W64# x) (W64# y) = isTrue# (x `eqWord64#` y) +neWord64 (W64# x) (W64# y) = isTrue# (x `neWord64#` y) +{-# INLINE [1] eqWord64 #-} +{-# INLINE [1] neWord64 #-} + instance Ord Word64 where - (W64# x#) < (W64# y#) = isTrue# (x# `ltWord64#` y#) - (W64# x#) <= (W64# y#) = isTrue# (x# `leWord64#` y#) - (W64# x#) > (W64# y#) = isTrue# (x# `gtWord64#` y#) - (W64# x#) >= (W64# y#) = isTrue# (x# `geWord64#` y#) + (<) = ltWord64 + (<=) = leWord64 + (>=) = geWord64 + (>) = gtWord64 +{-# INLINE [1] gtWord64 #-} +{-# INLINE [1] geWord64 #-} +{-# INLINE [1] ltWord64 #-} +{-# INLINE [1] leWord64 #-} +gtWord64, geWord64, ltWord64, leWord64 :: Word64 -> Word64 -> Bool +(W64# x) `gtWord64` (W64# y) = isTrue# (x `gtWord64#` y) +(W64# x) `geWord64` (W64# y) = isTrue# (x `geWord64#` y) +(W64# x) `ltWord64` (W64# y) = isTrue# (x `ltWord64#` y) +(W64# x) `leWord64` (W64# y) = isTrue# (x `leWord64#` y) + instance Num Word64 where (W64# x#) + (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#)) (W64# x#) - (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `minusInt64#` word64ToInt64# y#)) @@ -667,8 +777,35 @@ -- Operations may assume and must ensure that it holds only values -- from its logical range. -data {-# CTYPE "HsWord64" #-} Word64 = W64# Word# deriving (Eq, Ord) +data {-# CTYPE "HsWord64" #-} Word64 = W64# Word# -- ^ 64-bit unsigned integer type + +-- See GHC.Classes#matching_overloaded_methods_in_rules +instance Eq Word64 where + (==) = eqWord64 + (/=) = neWord64 + +eqWord64, neWord64 :: Word64 -> Word64 -> Bool +eqWord64 (W64# x) (W64# y) = isTrue# (x `eqWord#` y) +neWord64 (W64# x) (W64# y) = isTrue# (x `neWord#` y) +{-# INLINE [1] eqWord64 #-} +{-# INLINE [1] neWord64 #-} + +instance Ord Word64 where + (<) = ltWord64 + (<=) = leWord64 + (>=) = geWord64 + (>) = gtWord64 + +{-# INLINE [1] gtWord64 #-} +{-# INLINE [1] geWord64 #-} +{-# INLINE [1] ltWord64 #-} +{-# INLINE [1] leWord64 #-} +gtWord64, geWord64, ltWord64, leWord64 :: Word64 -> Word64 -> Bool +(W64# x) `gtWord64` (W64# y) = isTrue# (x `gtWord#` y) +(W64# x) `geWord64` (W64# y) = isTrue# (x `geWord#` y) +(W64# x) `ltWord64` (W64# y) = isTrue# (x `ltWord#` y) +(W64# x) `leWord64` (W64# y) = isTrue# (x `leWord#` y) instance Num Word64 where (W64# x#) + (W64# y#) = W64# (x# `plusWord#` y#) diff --git a/Numeric.hs b/Numeric.hs --- a/Numeric.hs +++ b/Numeric.hs @@ -56,6 +56,7 @@ -- * Miscellaneous fromRat, + Floating(..) ) where @@ -127,7 +128,7 @@ -- | Show /non-negative/ 'Integral' numbers in base 10. showInt :: Integral a => a -> ShowS showInt n0 cs0 - | n0 < 0 = error "Numeric.showInt: can't show negative numbers" + | n0 < 0 = errorWithoutStackTrace "Numeric.showInt: can't show negative numbers" | otherwise = go n0 cs0 where go n cs @@ -210,8 +211,8 @@ -- first argument, and the character representation specified by the second. showIntAtBase :: (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS showIntAtBase base toChr n0 r0 - | base <= 1 = error ("Numeric.showIntAtBase: applied to unsupported base " ++ show base) - | n0 < 0 = error ("Numeric.showIntAtBase: applied to negative number " ++ show n0) + | base <= 1 = errorWithoutStackTrace ("Numeric.showIntAtBase: applied to unsupported base " ++ show base) + | n0 < 0 = errorWithoutStackTrace ("Numeric.showIntAtBase: applied to negative number " ++ show n0) | otherwise = showIt (quotRem n0 base) r0 where showIt (n,d) r = seq c $ -- stricter than necessary diff --git a/Prelude.hs b/Prelude.hs --- a/Prelude.hs +++ b/Prelude.hs @@ -95,7 +95,7 @@ -- ** Miscellaneous functions id, const, (.), flip, ($), until, - asTypeOf, error, undefined, + asTypeOf, error, errorWithoutStackTrace, undefined, seq, ($!), -- * List operations diff --git a/System/CPUTime.hsc b/System/CPUTime.hsc --- a/System/CPUTime.hsc +++ b/System/CPUTime.hsc @@ -6,7 +6,7 @@ -- Module : System.CPUTime -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable @@ -18,7 +18,7 @@ #include "HsFFI.h" #include "HsBaseConfig.h" -module System.CPUTime +module System.CPUTime ( getCPUTime, -- :: IO Integer cpuTimePrecision -- :: Integer @@ -57,10 +57,10 @@ ##else ##endif -#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) +#if !defined(mingw32_HOST_OS) realToInteger :: Real a => a -> Integer realToInteger ct = round (realToFrac ct :: Double) - -- CTime, CClock, CUShort etc are in Real but not Fractional, + -- CTime, CClock, CUShort etc are in Real but not Fractional, -- so we must convert to Double before we can round it #endif @@ -72,7 +72,7 @@ getCPUTime :: IO Integer getCPUTime = do -#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) +#if !defined(mingw32_HOST_OS) -- getrusage() is right royal pain to deal with when targetting multiple -- versions of Solaris, since some versions supply it in libc (2.3 and 2.5), -- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back @@ -90,8 +90,8 @@ u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CSUSeconds s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CSUSeconds - return ((realToInteger u_sec * 1000000 + realToInteger u_usec + - realToInteger s_sec * 1000000 + realToInteger s_usec) + return ((realToInteger u_sec * 1000000 + realToInteger u_usec + + realToInteger s_sec * 1000000 + realToInteger s_usec) * 1000000) type CRUsage = () @@ -101,13 +101,13 @@ _ <- times p_tms u_ticks <- (#peek struct tms,tms_utime) p_tms :: IO CClock s_ticks <- (#peek struct tms,tms_stime) p_tms :: IO CClock - return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000) + return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000) `div` fromIntegral clockTicks) type CTms = () foreign import ccall unsafe times :: Ptr CTms -> IO CClock #else - ioException (IOError Nothing UnsupportedOperation + ioException (IOError Nothing UnsupportedOperation "getCPUTime" "can't get CPU time" Nothing) @@ -127,12 +127,12 @@ kt <- ft2psecs p_kernelTime return (ut + kt) else return 0 - where + where ft2psecs :: Ptr FILETIME -> IO Integer ft2psecs ft = do high <- (#peek FILETIME,dwHighDateTime) ft :: IO Word32 low <- (#peek FILETIME,dwLowDateTime) ft :: IO Word32 - -- Convert 100-ns units to picosecs (10^-12) + -- Convert 100-ns units to picosecs (10^-12) -- => multiply by 10^5. return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000) diff --git a/System/Environment.hs b/System/Environment.hs --- a/System/Environment.hs +++ b/System/Environment.hs @@ -299,7 +299,7 @@ -- IMPORTANT: Do not free `s` after calling putenv! -- -- According to SUSv2, the string passed to putenv becomes part of the - -- enviroment. + -- environment. throwErrnoIf_ (/= 0) "putenv" (c_putenv s) foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt diff --git a/System/Environment/ExecutablePath.hsc b/System/Environment/ExecutablePath.hsc --- a/System/Environment/ExecutablePath.hsc +++ b/System/Environment/ExecutablePath.hsc @@ -84,7 +84,7 @@ status2 <- c__NSGetExecutablePath newBuf bufsize if status2 == 0 then peekFilePath newBuf - else error "_NSGetExecutablePath: buffer too small" + else errorWithoutStackTrace "_NSGetExecutablePath: buffer too small" foreign import ccall unsafe "stdlib.h realpath" c_realpath :: CString -> CString -> IO CString @@ -145,7 +145,7 @@ go size = allocaArray (fromIntegral size) $ \ buf -> do ret <- c_GetModuleFileName nullPtr buf size case ret of - 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" + 0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error" _ | ret < size -> peekFilePath buf | otherwise -> go (size * 2) @@ -166,7 +166,7 @@ -- If argc > 0 then argv[0] is guaranteed by the standard -- to be a pointer to a null-terminated string. then peek p_argv >>= peek >>= peekFilePath - else error $ "getExecutablePath: " ++ msg + else errorWithoutStackTrace $ "getExecutablePath: " ++ msg where msg = "no OS specific implementation and program name couldn't be " ++ "found in argv" diff --git a/System/IO.hs b/System/IO.hs --- a/System/IO.hs +++ b/System/IO.hs @@ -480,7 +480,7 @@ -- Otherwise, something is wrong, because (break (== '.')) should -- always return a pair with either the empty string or a string -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" + _ -> errorWithoutStackTrace "bug in System.IO.openTempFile" findTempName = do rs <- rand_string diff --git a/System/Mem.hs b/System/Mem.hs --- a/System/Mem.hs +++ b/System/Mem.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Safe #-} - ----------------------------------------------------------------------------- -- | -- Module : System.Mem @@ -14,17 +12,30 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE Trustworthy #-} +-- allocation counter stuff is safe, but GHC.Conc.Sync is Unsafe + module System.Mem - ( performGC + ( + -- * Garbage collection + performGC , performMajorGC , performMinorGC + + -- * Allocation counter and limits + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit ) where --- | Triggers an immediate garbage collection. +import GHC.Conc.Sync + +-- | Triggers an immediate major garbage collection. performGC :: IO () performGC = performMajorGC --- | Triggers an immediate garbage collection. +-- | Triggers an immediate major garbage collection. -- -- @since 4.7.0.0 foreign import ccall "performMajorGC" performMajorGC :: IO () diff --git a/System/Mem/StableName.hs b/System/Mem/StableName.hs --- a/System/Mem/StableName.hs +++ b/System/Mem/StableName.hs @@ -1,10 +1,7 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MagicHash #-} -#if !defined(__PARALLEL_HASKELL__) {-# LANGUAGE UnboxedTuples #-} -#endif ----------------------------------------------------------------------------- -- | @@ -38,8 +35,6 @@ eqStableName ) where -import Data.Typeable - import GHC.IO ( IO(..) ) import GHC.Base ( Int(..), StableName#, makeStableName# , eqStableName#, stableNameToInt# ) @@ -76,41 +71,25 @@ -} data StableName a = StableName (StableName# a) - deriving Typeable -- | Makes a 'StableName' for an arbitrary object. The object passed as -- the first argument is not evaluated by 'makeStableName'. makeStableName :: a -> IO (StableName a) -#if defined(__PARALLEL_HASKELL__) -makeStableName a = - error "makeStableName not implemented in parallel Haskell" -#else makeStableName a = IO $ \ s -> case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) -#endif -- | 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 -#if defined(__PARALLEL_HASKELL__) -hashStableName (StableName sn) = - error "hashStableName not implemented in parallel Haskell" -#else hashStableName (StableName sn) = I# (stableNameToInt# sn) -#endif instance Eq (StableName a) where -#if defined(__PARALLEL_HASKELL__) (StableName sn1) == (StableName sn2) = - error "eqStableName not implemented in parallel Haskell" -#else - (StableName sn1) == (StableName sn2) = case eqStableName# sn1 sn2 of 0# -> False _ -> True -#endif -- | Equality on 'StableName' that does not require that the types of -- the arguments match. diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs --- a/System/Posix/Internals.hs +++ b/System/Posix/Internals.hs @@ -62,18 +62,18 @@ -- --------------------------------------------------------------------------- -- Types -type CFLock = () +data {-# CTYPE "struct flock" #-} CFLock data {-# CTYPE "struct group" #-} CGroup -type CLconv = () -type CPasswd = () -type CSigaction = () +data {-# CTYPE "struct lconv" #-} CLconv +data {-# CTYPE "struct passwd" #-} CPasswd +data {-# CTYPE "struct sigaction" #-} CSigaction data {-# CTYPE "sigset_t" #-} CSigset -type CStat = () -type CTermios = () -type CTm = () -type CTms = () -type CUtimbuf = () -type CUtsname = () +data {-# CTYPE "struct stat" #-} CStat +data {-# CTYPE "struct termios" #-} CTermios +data {-# CTYPE "struct tm" #-} CTm +data {-# CTYPE "struct tms" #-} CTms +data {-# CTYPE "struct utimbuf" #-} CUtimbuf +data {-# CTYPE "struct utsname" #-} CUtsname type FD = CInt @@ -134,7 +134,7 @@ Nothing fdGetMode :: FD -> IO IOMode -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#if defined(mingw32_HOST_OS) fdGetMode _ = do -- We don't have a way of finding out which flags are set on FDs -- on Windows, so make a handle that thinks that anything goes. @@ -314,7 +314,7 @@ -- Turning on non-blocking for a file descriptor setNonBlockingFD :: FD -> Bool -> IO () -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +#if !defined(mingw32_HOST_OS) setNonBlockingFD fd set = do flags <- throwErrnoIfMinus1Retry "setNonBlockingFD" (c_fcntl_read fd const_f_getfl) @@ -336,7 +336,7 @@ -- ----------------------------------------------------------------------------- -- Set close-on-exec for a file descriptor -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +#if !defined(mingw32_HOST_OS) setCloseOnExec :: FD -> IO () setCloseOnExec fd = do throwErrnoIfMinus1_ "setCloseOnExec" $ @@ -346,56 +346,122 @@ -- ----------------------------------------------------------------------------- -- foreign imports -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +#if !defined(mingw32_HOST_OS) type CFilePath = CString #else type CFilePath = CWString #endif -foreign import ccall unsafe "HsBase.h access" +foreign import ccall unsafe "HsBase.h __hscore_open" + c_open :: CFilePath -> CInt -> CMode -> IO CInt + +foreign import ccall safe "HsBase.h __hscore_open" + c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt + +foreign import ccall unsafe "HsBase.h __hscore_fstat" + c_fstat :: CInt -> Ptr CStat -> IO CInt + +foreign import ccall unsafe "HsBase.h __hscore_lstat" + lstat :: CFilePath -> Ptr CStat -> IO CInt + +{- Note: Win32 POSIX functions +Functions that are not part of the POSIX standards were +at some point deprecated by Microsoft. This deprecation +was performed by renaming the functions according to the +C++ ABI Section 17.6.4.3.2b. This was done to free up the +namespace of normal Windows programs since Windows isn't +POSIX compliant anyway. + +These were working before since the RTS was re-exporting +these symbols under the undeprecated names. This is no longer +being done. See #11223 + +See https://msdn.microsoft.com/en-us/library/ms235384.aspx +for more. +-} +#if defined(mingw32_HOST_OS) +foreign import ccall unsafe "io.h _lseeki64" + c_lseek :: CInt -> Int64 -> CInt -> IO Int64 + +foreign import ccall unsafe "HsBase.h _access" c_access :: CString -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h chmod" +foreign import ccall unsafe "HsBase.h _chmod" c_chmod :: CString -> CMode -> IO CInt -foreign import ccall unsafe "HsBase.h close" +foreign import ccall unsafe "HsBase.h _close" c_close :: CInt -> IO CInt -foreign import ccall unsafe "HsBase.h creat" +foreign import ccall unsafe "HsBase.h _creat" c_creat :: CString -> CMode -> IO CInt -foreign import ccall unsafe "HsBase.h dup" +foreign import ccall unsafe "HsBase.h _dup" c_dup :: CInt -> IO CInt -foreign import ccall unsafe "HsBase.h dup2" +foreign import ccall unsafe "HsBase.h _dup2" c_dup2 :: CInt -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h __hscore_fstat" - c_fstat :: CInt -> Ptr CStat -> IO CInt - -foreign import ccall unsafe "HsBase.h isatty" +foreign import ccall unsafe "HsBase.h _isatty" c_isatty :: CInt -> IO CInt -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -foreign import ccall unsafe "io.h _lseeki64" - c_lseek :: CInt -> Int64 -> CInt -> IO Int64 +-- See Note: CSsize +foreign import capi unsafe "HsBase.h _read" + c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize + +-- See Note: CSsize +foreign import capi safe "HsBase.h _read" + c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize + +foreign import ccall unsafe "HsBase.h _umask" + c_umask :: CMode -> IO CMode + +-- See Note: CSsize +foreign import capi unsafe "HsBase.h _write" + c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize + +-- See Note: CSsize +foreign import capi safe "HsBase.h _write" + c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize + +foreign import ccall unsafe "HsBase.h _unlink" + c_unlink :: CString -> IO CInt + +foreign import ccall unsafe "HsBase.h _pipe" + c_pipe :: Ptr CInt -> IO CInt + +foreign import capi unsafe "HsBase.h _utime" + c_utime :: CString -> Ptr CUtimbuf -> IO CInt + +foreign import ccall unsafe "HsBase.h _getpid" + c_getpid :: IO CPid #else -- We use CAPI as on some OSs (eg. Linux) this is wrapped by a macro -- which redirects to the 64-bit-off_t versions when large file -- support is enabled. foreign import capi unsafe "unistd.h lseek" c_lseek :: CInt -> COff -> CInt -> IO COff -#endif -foreign import ccall unsafe "HsBase.h __hscore_lstat" - lstat :: CFilePath -> Ptr CStat -> IO CInt +foreign import ccall unsafe "HsBase.h access" + c_access :: CString -> CInt -> IO CInt -foreign import ccall unsafe "HsBase.h __hscore_open" - c_open :: CFilePath -> CInt -> CMode -> IO CInt +foreign import ccall unsafe "HsBase.h chmod" + c_chmod :: CString -> CMode -> IO CInt -foreign import ccall safe "HsBase.h __hscore_open" - c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt +foreign import ccall unsafe "HsBase.h close" + c_close :: CInt -> IO CInt +foreign import ccall unsafe "HsBase.h creat" + c_creat :: CString -> CMode -> IO CInt + +foreign import ccall unsafe "HsBase.h dup" + c_dup :: CInt -> IO CInt + +foreign import ccall unsafe "HsBase.h dup2" + c_dup2 :: CInt -> CInt -> IO CInt + +foreign import ccall unsafe "HsBase.h isatty" + c_isatty :: CInt -> IO CInt + -- See Note: CSsize foreign import capi unsafe "HsBase.h read" c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize @@ -404,9 +470,6 @@ foreign import capi safe "HsBase.h read" c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall unsafe "HsBase.h __hscore_stat" - c_stat :: CFilePath -> Ptr CStat -> IO CInt - foreign import ccall unsafe "HsBase.h umask" c_umask :: CMode -> IO CMode @@ -418,16 +481,26 @@ foreign import capi safe "HsBase.h write" c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize -foreign import ccall unsafe "HsBase.h __hscore_ftruncate" - c_ftruncate :: CInt -> COff -> IO CInt - foreign import ccall unsafe "HsBase.h unlink" c_unlink :: CString -> IO CInt +foreign import ccall unsafe "HsBase.h pipe" + c_pipe :: Ptr CInt -> IO CInt + +foreign import capi unsafe "HsBase.h utime" + c_utime :: CString -> Ptr CUtimbuf -> IO CInt + foreign import ccall unsafe "HsBase.h getpid" c_getpid :: IO CPid +#endif -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +foreign import ccall unsafe "HsBase.h __hscore_stat" + c_stat :: CFilePath -> Ptr CStat -> IO CInt + +foreign import ccall unsafe "HsBase.h __hscore_ftruncate" + c_ftruncate :: CInt -> COff -> IO CInt + +#if !defined(mingw32_HOST_OS) foreign import capi unsafe "HsBase.h fcntl" c_fcntl_read :: CInt -> CInt -> IO CInt @@ -447,9 +520,6 @@ foreign import capi unsafe "HsBase.h mkfifo" c_mkfifo :: CString -> CMode -> IO CInt -foreign import ccall unsafe "HsBase.h pipe" - c_pipe :: Ptr CInt -> IO CInt - foreign import capi unsafe "signal.h sigemptyset" c_sigemptyset :: Ptr CSigset -> IO CInt @@ -467,9 +537,6 @@ foreign import capi unsafe "HsBase.h tcsetattr" c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt -foreign import capi unsafe "HsBase.h utime" - c_utime :: CString -> Ptr CUtimbuf -> IO CInt - foreign import ccall unsafe "HsBase.h waitpid" c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid #endif @@ -539,7 +606,7 @@ #endif s_issock :: CMode -> Bool -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +#if !defined(mingw32_HOST_OS) s_issock cmode = c_s_issock cmode /= 0 foreign import capi unsafe "sys/stat.h S_ISSOCK" c_s_issock :: CMode -> CInt #else diff --git a/System/Posix/Types.hs b/System/Posix/Types.hs --- a/System/Posix/Types.hs +++ b/System/Posix/Types.hs @@ -4,7 +4,7 @@ , MagicHash , GeneralizedNewtypeDeriving #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -92,7 +92,6 @@ import Foreign import Foreign.C -import Data.Typeable -- import Data.Bits import GHC.Base diff --git a/System/Timeout.hs b/System/Timeout.hs --- a/System/Timeout.hs +++ b/System/Timeout.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE AutoDeriveTypeable, StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ------------------------------------------------------------------------------- -- | @@ -29,14 +29,13 @@ uninterruptibleMask_, asyncExceptionToException, asyncExceptionFromException) -import Data.Typeable import Data.Unique (Unique, newUnique) -- An internal type that is thrown as a dynamic exception to -- interrupt the running IO computation when the timeout has -- expired. -newtype Timeout = Timeout Unique deriving (Eq, Typeable) +newtype Timeout = Timeout Unique deriving (Eq) 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 @@ -76,6 +76,8 @@ import GHC.List ( replicate, null ) import GHC.Base hiding ( many ) +import Control.Monad.Fail + infixr 5 +++, <++ ------------------------------------------------------------------------ @@ -103,7 +105,7 @@ -- Monad, MonadPlus instance Applicative P where - pure = return + pure x = Result x Fail (<*>) = ap instance MonadPlus P where @@ -111,8 +113,6 @@ 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 @@ -121,6 +121,9 @@ fail _ = Fail +instance MonadFail P where + fail _ = Fail + instance Alternative P where empty = Fail @@ -161,14 +164,16 @@ 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)) +instance MonadFail ReadP where + fail _ = R (\_ -> Fail) + instance Alternative ReadP where empty = mzero (<|>) = mplus @@ -243,7 +248,7 @@ gath _ Fail = Fail gath l (Look f) = Look (\s -> gath l (f s)) gath l (Result k p) = k (l []) <|> gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" + gath _ (Final _) = errorWithoutStackTrace "do not use readS_to_P in gather!" -- --------------------------------------------------------------------------- -- Derived operations diff --git a/Text/ParserCombinators/ReadPrec.hs b/Text/ParserCombinators/ReadPrec.hs --- a/Text/ParserCombinators/ReadPrec.hs +++ b/Text/ParserCombinators/ReadPrec.hs @@ -64,6 +64,8 @@ import GHC.Num( Num(..) ) import GHC.Base +import qualified Control.Monad.Fail as MonadFail + -- --------------------------------------------------------------------------- -- The readPrec type @@ -75,13 +77,15 @@ 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) + +instance MonadFail.MonadFail ReadPrec where + fail s = P (\_ -> fail s) instance MonadPlus ReadPrec where mzero = pfail diff --git a/Text/Printf.hs b/Text/Printf.hs --- a/Text/Printf.hs +++ b/Text/Printf.hs @@ -461,7 +461,7 @@ ("ll", toInteger (minBound :: Int64)), ("L", toInteger (minBound :: Int64)) ] -parseIntFormat :: Integral a => a -> String -> FormatParse +parseIntFormat :: a -> String -> FormatParse parseIntFormat _ s = case foldr matchPrefix Nothing intModifierMap of Just m -> m @@ -871,7 +871,7 @@ -- -- @since 4.7.0.0 perror :: String -> a -perror s = error $ "printf: " ++ s +perror s = errorWithoutStackTrace $ "printf: " ++ s -- | Calls 'perror' to indicate an unknown format letter for -- a given type. diff --git a/Text/Read.hs b/Text/Read.hs --- a/Text/Read.hs +++ b/Text/Read.hs @@ -87,4 +87,4 @@ -- | The 'read' function reads input from a string, which must be -- completely consumed by the input process. read :: Read a => String -> a -read s = either error id (readEither s) +read s = either errorWithoutStackTrace id (readEither s) diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs --- a/Text/Read/Lex.hs +++ b/Text/Read/Lex.hs @@ -30,6 +30,8 @@ , readOctP , readDecP , readHexP + + , isSymbolChar ) where @@ -39,7 +41,8 @@ import GHC.Char import GHC.Num( Num(..), Integer ) import GHC.Show( Show(..) ) -import GHC.Unicode( isSpace, isAlpha, isAlphaNum ) +import GHC.Unicode + ( GeneralCategory(..), generalCategory, isSpace, isAlpha, isAlphaNum ) import GHC.Real( Rational, (%), fromIntegral, Integral, toInteger, (^), quot, even ) import GHC.List @@ -198,9 +201,11 @@ lexPunc = do c <- satisfy isPuncChar return (Punc [c]) - where - isPuncChar c = c `elem` ",;()[]{}`" +-- | The @special@ character class as defined in the Haskell Report. +isPuncChar :: Char -> Bool +isPuncChar c = c `elem` ",;()[]{}`" + -- ---------------------------------------------------------------------- -- Symbols @@ -211,10 +216,19 @@ return (Punc s) -- Reserved-ops count as punctuation else return (Symbol s) - where - isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~" - reserved_ops = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"] + where + reserved_ops = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"] +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> not (c `elem` "'\"") + ConnectorPunctuation -> c /= '_' + _ -> False -- ---------------------------------------------------------------------- -- identifiers @@ -493,7 +507,7 @@ where d = d1 * b + d2 combine _ [] = [] - combine _ [_] = error "this should not happen" + combine _ [_] = errorWithoutStackTrace "this should not happen" -- Calculate a Rational from the exponent [of 10 to multiply with], -- the integral part of the mantissa and the digits of the fractional @@ -525,7 +539,7 @@ | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10) | otherwise = Nothing -valDig _ _ = error "valDig: Bad base" +valDig _ _ = errorWithoutStackTrace "valDig: Bad base" valDecDig :: Char -> Maybe Int valDecDig c diff --git a/Text/Show/Functions.hs b/Text/Show/Functions.hs --- a/Text/Show/Functions.hs +++ b/Text/Show/Functions.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} -- This module deliberately declares orphan instances: -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} ----------------------------------------------------------------------------- -- | diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,5 +1,5 @@ name: base -version: 4.8.2.0 +version: 4.9.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -52,15 +52,9 @@ Manual: True Default: False -Flag integer-gmp2 - Description: Use integer-gmp2 - Manual: True - Default: False - Library default-language: Haskell2010 other-extensions: - AutoDeriveTypeable BangPatterns CApiFFI CPP @@ -99,15 +93,16 @@ UnliftedFFITypes Unsafe - build-depends: rts == 1.0.*, ghc-prim == 0.4.* + build-depends: rts == 1.0.*, ghc-prim == 0.5.* + + -- 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 if flag(integer-gmp) - build-depends: integer-gmp >= 0.5.1 && < 0.6 - cpp-options: -DOPTIMISE_INTEGER_GCD_LCM - - if flag(integer-gmp2) build-depends: integer-gmp >= 1.0 && < 1.1 cpp-options: -DOPTIMISE_INTEGER_GCD_LCM @@ -123,8 +118,10 @@ Control.Exception Control.Exception.Base Control.Monad + Control.Monad.Fail Control.Monad.Fix Control.Monad.Instances + Control.Monad.IO.Class Control.Monad.ST Control.Monad.ST.Lazy Control.Monad.ST.Lazy.Safe @@ -147,16 +144,24 @@ Data.Foldable Data.Function Data.Functor + Data.Functor.Classes + Data.Functor.Compose + Data.Functor.Const Data.Functor.Identity + Data.Functor.Product + Data.Functor.Sum Data.IORef Data.Int Data.Ix + Data.Kind Data.List + Data.List.NonEmpty Data.Maybe Data.Monoid Data.Ord Data.Proxy Data.Ratio + Data.Semigroup Data.STRef Data.STRef.Lazy Data.STRef.Strict @@ -208,6 +213,8 @@ GHC.Environment GHC.Err GHC.Exception + GHC.ExecutionStack + GHC.ExecutionStack.Internal GHC.Exts GHC.Fingerprint GHC.Fingerprint.Type @@ -239,15 +246,16 @@ GHC.IO.Handle.Text GHC.IO.Handle.Types GHC.IO.IOMode + GHC.IO.Unsafe GHC.IOArray GHC.IORef - GHC.IP GHC.Int GHC.List GHC.MVar GHC.Natural GHC.Num GHC.OldList + GHC.OverloadedLabels GHC.PArr GHC.Pack GHC.Profiling @@ -259,9 +267,10 @@ GHC.StaticPtr GHC.STRef GHC.Show - GHC.SrcLoc GHC.Stable GHC.Stack + GHC.Stack.CCS + GHC.Stack.Types GHC.Stats GHC.Storable GHC.TopHandler @@ -323,11 +332,18 @@ HsBase.h WCsubst.h consUtils.h - Typeable.h -- OS Specific if os(windows) - extra-libraries: wsock32, user32, shell32 + -- Windows requires some extra libraries for linking because the RTS + -- is no longer re-exporting them. + -- msvcrt: standard C library. The RTS will automatically include this, + -- but is added for completeness. + -- mingwex: provides C99 compatibility. libm is a stub on MingW. + -- mingw32: Unfortunately required because of a resource leak between + -- mingwex and mingw32. the __math_err symbol is defined in + -- mingw32 which is required by mingwex. + extra-libraries: wsock32, user32, shell32, msvcrt, mingw32, mingwex exposed-modules: GHC.IO.Encoding.CodePage.API GHC.IO.Encoding.CodePage.Table @@ -352,6 +368,6 @@ 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 + ghc-options: -this-unit-id base diff --git a/cbits/Win32Utils.c b/cbits/Win32Utils.c --- a/cbits/Win32Utils.c +++ b/cbits/Win32Utils.c @@ -4,7 +4,7 @@ Useful Win32 bits ------------------------------------------------------------------------- */ -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#if defined(_WIN32) #include "HsBase.h" diff --git a/cbits/consUtils.c b/cbits/consUtils.c --- a/cbits/consUtils.c +++ b/cbits/consUtils.c @@ -3,7 +3,7 @@ * * Win32 Console API support */ -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) /* to the end */ #include "consUtils.h" @@ -108,4 +108,4 @@ return -1; } -#endif /* defined(__MINGW32__) || ... */ +#endif /* defined(_WIN32) || ... */ diff --git a/cbits/iconv.c b/cbits/iconv.c --- a/cbits/iconv.c +++ b/cbits/iconv.c @@ -1,4 +1,4 @@ -#ifndef __MINGW32__ +#ifndef _WIN32 #include #include diff --git a/cbits/inputReady.c b/cbits/inputReady.c --- a/cbits/inputReady.c +++ b/cbits/inputReady.c @@ -17,7 +17,7 @@ fdReady(int fd, int write, int msecs, int isSock) { if -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#if defined(_WIN32) ( isSock ) { #else ( 1 ) { @@ -54,7 +54,7 @@ /* 1 => Input ready, 0 => not ready, -1 => error */ return (ready); } -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#if defined(_WIN32) else { DWORD rc; HANDLE hFile = (HANDLE)_get_osfhandle(fd); diff --git a/cbits/primFloat.c b/cbits/primFloat.c --- a/cbits/primFloat.c +++ b/cbits/primFloat.c @@ -108,7 +108,7 @@ * Predicates for testing for extreme IEEE fp values. */ -/* In case you don't suppport IEEE, you'll just get dummy defs.. */ +/* In case you don't support IEEE, you'll just get dummy defs.. */ #ifdef IEEE_FLOATING_POINT HsInt diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,176 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.9.0.0 *May 2016* + + * Bundled with GHC 8.0 + + * `error` and `undefined` now print a partial stack-trace alongside the error message. + + * New `errorWithoutStackTrace` function throws an error without printing the stack trace. + + * The restore operation provided by `mask` and `uninterruptibleMask` now + restores the previous masking state whatever the current masking state is. + + * New `GHC.Generics.packageName` operation + + * Redesigned `GHC.Stack.CallStack` data type. As a result, `CallStack`'s + `Show` instance produces different output, and `CallStack` no longer has an + `Eq` instance. + + * New `GHC.Generics.packageName` operation + + * New `GHC.Stack.Types` module now contains the definition of + `CallStack` and `SrcLoc` + + * New `GHC.Stack.Types.emptyCallStack` function builds an empty `CallStack` + + * New `GHC.Stack.Types.freezeCallStack` function freezes a `CallStack` preventing future `pushCallStack` operations from having any effect + + * New `GHC.Stack.Types.pushCallStack` function pushes a call-site onto a `CallStack` + + * New `GHC.Stack.Types.fromCallSiteList` function creates a `CallStack` from + a list of call-sites (i.e., `[(String, SrcLoc)]`) + + * `GHC.SrcLoc` has been removed + + * `GHC.Stack.showCallStack` and `GHC.SrcLoc.showSrcLoc` are now called + `GHC.Stack.prettyCallStack` and `GHC.Stack.prettySrcLoc` respectively + + * add `Data.List.NonEmpty` and `Data.Semigroup` (to become + super-class of `Monoid` in the future). These modules were + provided by the `semigroups` package previously. (#10365) + + * Add `selSourceUnpackedness`, `selSourceStrictness`, and + `selDecidedStrictness`, three functions which look up strictness + information of a field in a data constructor, to the `Selector` type class + in `GHC.Generics` (#10716) + + * Add `URec`, `UAddr`, `UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord` to + `GHC.Generics` as part of making GHC generics capable of handling + unlifted types (#10868) + + * The `Eq`, `Ord`, `Read`, and `Show` instances for `U1` now use lazier + pattern-matching + + * 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. + + * The `MINIMAL` definition of `Arrow` is now `arr AND (first OR (***))`. + + * The `MINIMAL` definition of `ArrowChoice` is now `left OR (+++)`. + + * Exported `GiveGCStats`, `DoCostCentres`, `DoHeapProfile`, `DoTrace`, + `RtsTime`, and `RtsNat` from `GHC.RTS.Flags` + + * New function `GHC.IO.interruptible` used to correctly implement + `Control.Exception.allowInterrupt` (#9516) + + * Made `PatternMatchFail`, `RecSelError`, `RecConError`, `RecUpdError`, + `NoMethodError`, and `AssertionFailed` newtypes (#10738) + + * New module `Control.Monad.IO.Class` (previously provided by `transformers` + package). (#10773) + + * New modules `Data.Functor.Classes`, `Data.Functor.Compose`, + `Data.Functor.Product`, and `Data.Functor.Sum` (previously provided by + `transformers` package). (#11135) + + * New instances for `Proxy`: `Eq1`, `Ord1`, `Show1`, `Read1`. All + of the classes are from `Data.Functor.Classes` (#11756). + + * New module `Control.Monad.Fail` providing new `MonadFail(fail)` + class (#10751) + + * Add `GHC.TypeLits.TypeError` and `ErrorMessage` to allow users + to define custom compile-time error messages. + + * Redesign `GHC.Generics` to use type-level literals to represent the + metadata of generic representation types (#9766) + + * The `IsString` instance for `[Char]` has been modified to eliminate + ambiguity arising from overloaded strings and functions like `(++)`. + + * Move `Const` from `Control.Applicative` to its own module in + `Data.Functor.Const`. (#11135) + + * Re-export `Const` from `Control.Applicative` for backwards compatibility. + + * Expand `Floating` class to include operations that allow for better + precision: `log1p`, `expm1`, `log1pexp` and `log1mexp`. These are not + available from `Prelude`, but the full class is exported from `Numeric`. + + * New `Control.Exception.TypeError` datatype, which is thrown when an + expression fails to typecheck when run using `-fdefer-type-errors` (#10284) + +### New instances + + * `Alt`, `Dual`, `First`, `Last`, `Product`, and `Sum` now have `Data`, + `MonadZip`, and `MonadFix` instances + + * The datatypes in `GHC.Generics` now have `Enum`, `Bounded`, `Ix`, + `Functor`, `Applicative`, `Monad`, `MonadFix`, `MonadPlus`, `MonadZip`, + `Foldable`, `Foldable`, `Traversable`, `Generic1`, and `Data` instances + as appropriate. + + * `Maybe` now has a `MonadZip` instance + + * `All` and `Any` now have `Data` instances + + * `Dual`, `First`, `Last`, `Product`, and `Sum` now have `Foldable` and + `Traversable` instances + + * `Dual`, `Product`, and `Sum` now have `Functor`, `Applicative`, and + `Monad` instances + + * `(,) a` now has a `Monad` instance + + * `ZipList` now has `Foldable` and `Traversable` instances + + * `Identity` now has `Semigroup` and `Monoid` instances + + * `Identity` and `Const` now have `Bits`, `Bounded`, `Enum`, `FiniteBits`, + `Floating`, `Fractional`, `Integral`, `IsString`, `Ix`, `Num`, `Real`, + `RealFloat`, `RealFrac` and `Storable` instances. (#11210, #11790) + + * `()` now has a `Storable` instance + + * `Complex` now has `Generic`, `Generic1`, `Functor`, `Foldable`, `Traversable`, + `Applicative`, and `Monad` instances + + * `System.Exit.ExitCode` now has a `Generic` instance + + * `Data.Version.Version` now has a `Generic` instance + + * `IO` now has a `Monoid` instance + + * Add `MonadPlus IO` and `Alternative IO` instances + (previously orphans in `transformers`) (#10755) + + * `CallStack` now has an `IsList` instance + +### Generalizations + + * Generalize `Debug.Trace.{traceM, traceShowM}` from `Monad` to `Applicative` + (#10023) + + * Redundant typeclass constraints have been removed: + - `Data.Ratio.{denominator,numerator}` have no `Integral` constraint anymore + - **TODO** + + * Generalise `forever` from `Monad` to `Applicative` + + * Generalize `filterM`, `mapAndUnzipM`, `zipWithM`, `zipWithM_`, `replicateM`, + `replicateM_` from `Monad` to `Applicative` (#10168) + + * The `Generic` instance for `Proxy` is now poly-kinded (#10775) + + * Enable `PolyKinds` in the `Data.Functor.Const` module to give `Const` + the kind `* -> k -> *`. (#10039) + + ## 4.8.2.0 *Oct 2015* * Bundled with GHC 7.10.3 @@ -16,7 +187,7 @@ * `Lifetime` is now exported from `GHC.Event` - * Implicit-parameter based source location support exposed in `GHC.SrcLoc`. + * Implicit-parameter based source location support exposed in `GHC.SrcLoc` and `GHC.Stack`. See GHC User's Manual for more information. ## 4.8.0.0 *Mar 2015* diff --git a/configure b/configure --- a/configure +++ b/configure @@ -668,6 +668,7 @@ docdir oldincludedir includedir +runstatedir localstatedir sharedstatedir sysconfdir @@ -690,7 +691,6 @@ ac_subst_files='' ac_user_opts=' enable_option_checking -with_cc enable_largefile with_iconv_includes with_iconv_libraries @@ -742,6 +742,7 @@ sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -994,6 +995,15 @@ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1131,7 +1141,7 @@ for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir + libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1284,6 +1294,7 @@ --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] @@ -1323,7 +1334,6 @@ Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) -C compiler --with-iconv-includes directory containing iconv.h --with-iconv-libraries directory containing iconv library @@ -1455,60 +1465,6 @@ } # ac_fn_c_try_compile -# ac_fn_c_check_type LINENO TYPE VAR INCLUDES -# ------------------------------------------- -# Tests whether TYPE exists after having included INCLUDES, setting cache -# variable VAR accordingly. -ac_fn_c_check_type () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - eval "$3=no" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -if (sizeof ($2)) - return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -if (sizeof (($2))) - return 0; - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - eval "$3=yes" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_type - # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. @@ -1546,6 +1502,97 @@ } # ac_fn_c_try_cpp +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} +( $as_echo "## ------------------------------------ ## +## Report this to libraries@haskell.org ## +## ------------------------------------ ##" + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes @@ -1619,96 +1666,59 @@ } # ac_fn_c_check_header_compile -# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES -# ------------------------------------------------------- -# Tests whether HEADER exists, giving a warning if it cannot be compiled using -# the include files in INCLUDES and setting the cache variable VAR -# accordingly. -ac_fn_c_check_header_mongrel () +# ac_fn_c_check_type LINENO TYPE VAR INCLUDES +# ------------------------------------------- +# Tests whether TYPE exists after having included INCLUDES, setting cache +# variable VAR accordingly. +ac_fn_c_check_type () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } else - # Is the header compilable? -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 -$as_echo_n "checking $2 usability... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext + eval "$3=no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 -#include <$2> +int +main () +{ +if (sizeof ($2)) + return 0; + ; + return 0; +} _ACEOF if ac_fn_c_try_compile "$LINENO"; then : - ac_header_compiler=yes -else - ac_header_compiler=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 -$as_echo_n "checking $2 presence... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ -#include <$2> +$4 +int +main () +{ +if (sizeof (($2))) + return 0; + ; + return 0; +} _ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - ac_header_preproc=yes -else - ac_header_preproc=no -fi -rm -f conftest.err conftest.i conftest.$ac_ext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } +if ac_fn_c_try_compile "$LINENO"; then : -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( - yes:no: ) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} - ;; - no:yes:* ) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} -( $as_echo "## ------------------------------------ ## -## Report this to libraries@haskell.org ## -## ------------------------------------ ##" - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 else - eval "$3=\$ac_header_compiler" + eval "$3=yes" fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno -} # ac_fn_c_check_header_mongrel +} # ac_fn_c_check_type # ac_fn_c_try_link LINENO # ----------------------- @@ -2504,12 +2514,6 @@ NONENONEs,x,x, && program_prefix=${target_alias}- - -# Check whether --with-cc was given. -if test "${with_cc+set}" = set; then : - withval=$with_cc; CC=$withval -fi - ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' @@ -3300,19 +3304,6 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for WINDOWS platform" >&5 -$as_echo_n "checking for WINDOWS platform... " >&6; } -case $host in - *mingw32*|*mingw64*|*cygwin*|*msys*) - WINDOWS=YES;; - *) - WINDOWS=NO;; -esac -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $WINDOWS" >&5 -$as_echo "$WINDOWS" >&6; } - -# do we have long longs? - ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' @@ -3710,6 +3701,80 @@ done + + ac_fn_c_check_header_mongrel "$LINENO" "minix/config.h" "ac_cv_header_minix_config_h" "$ac_includes_default" +if test "x$ac_cv_header_minix_config_h" = xyes; then : + MINIX=yes +else + MINIX= +fi + + + if test "$MINIX" = yes; then + +$as_echo "#define _POSIX_SOURCE 1" >>confdefs.h + + +$as_echo "#define _POSIX_1_SOURCE 2" >>confdefs.h + + +$as_echo "#define _MINIX 1" >>confdefs.h + + fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether it is safe to define __EXTENSIONS__" >&5 +$as_echo_n "checking whether it is safe to define __EXTENSIONS__... " >&6; } +if ${ac_cv_safe_to_define___extensions__+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +# define __EXTENSIONS__ 1 + $ac_includes_default +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_safe_to_define___extensions__=yes +else + ac_cv_safe_to_define___extensions__=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_safe_to_define___extensions__" >&5 +$as_echo "$ac_cv_safe_to_define___extensions__" >&6; } + test $ac_cv_safe_to_define___extensions__ = yes && + $as_echo "#define __EXTENSIONS__ 1" >>confdefs.h + + $as_echo "#define _ALL_SOURCE 1" >>confdefs.h + + $as_echo "#define _GNU_SOURCE 1" >>confdefs.h + + $as_echo "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h + + $as_echo "#define _TANDEM_SOURCE 1" >>confdefs.h + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for WINDOWS platform" >&5 +$as_echo_n "checking for WINDOWS platform... " >&6; } +case $host in + *mingw32*|*mingw64*|*cygwin*|*msys*) + WINDOWS=YES;; + *) + WINDOWS=NO;; +esac +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $WINDOWS" >&5 +$as_echo "$WINDOWS" >&6; } + +# do we have long longs? ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default" if test "x$ac_cv_type_long_long" = xyes; then : @@ -4320,7 +4385,7 @@ # Check whether --with-iconv-includes was given. if test "${with_iconv_includes+set}" = set; then : - withval=$with_iconv_includes; ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval" + withval=$with_iconv_includes; ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval $CPPFLAGS" else ICONV_INCLUDE_DIRS= fi @@ -4329,7 +4394,7 @@ # Check whether --with-iconv-libraries was given. if test "${with_iconv_libraries+set}" = set; then : - withval=$with_iconv_libraries; ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval" + withval=$with_iconv_libraries; ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval $LDFLAGS" else ICONV_LIB_DIRS= fi @@ -20551,6 +20616,12 @@ # Hack - md5.h needs HsFFI.h. Is there a better way to do this? CFLAGS="-I../../includes $CFLAGS" +ac_fn_c_check_type "$LINENO" "struct MD5Context" "ac_cv_type_struct_MD5Context" "#include \"include/md5.h\" +" +if test "x$ac_cv_type_struct_MD5Context" = xyes; then : + +fi + # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,3 +1,4 @@ +AC_PREREQ([2.60]) AC_INIT([Haskell base package], [1.0], [libraries@haskell.org], [base]) # Safety check: Ensure that we are in the correct source directory. @@ -9,10 +10,9 @@ AC_CANONICAL_HOST AC_CANONICAL_TARGET -AC_ARG_WITH([cc], - [C compiler], - [CC=$withval]) -AC_PROG_CC() +AC_PROG_CC +dnl make extensions visible to allow feature-tests to detect them lateron +AC_USE_SYSTEM_EXTENSIONS AC_MSG_CHECKING(for WINDOWS platform) case $host in @@ -92,13 +92,13 @@ AC_ARG_WITH([iconv-includes], [AC_HELP_STRING([--with-iconv-includes], [directory containing iconv.h])], - [ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval"], + [ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval $CPPFLAGS"], [ICONV_INCLUDE_DIRS=]) AC_ARG_WITH([iconv-libraries], [AC_HELP_STRING([--with-iconv-libraries], [directory containing iconv library])], - [ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval"], + [ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval $LDFLAGS"], [ICONV_LIB_DIRS=]) AC_SUBST(ICONV_INCLUDE_DIRS) @@ -205,7 +205,10 @@ # Hack - md5.h needs HsFFI.h. Is there a better way to do this? CFLAGS="-I../../includes $CFLAGS" -AC_CHECK_SIZEOF([struct MD5Context], ,[#include "include/md5.h"]) +dnl Calling AC_CHECK_TYPE(T) makes AC_CHECK_SIZEOF(T) abort on failure +dnl instead of considering sizeof(T) as 0. +AC_CHECK_TYPE([struct MD5Context], [], [], [#include "include/md5.h"]) +AC_CHECK_SIZEOF([struct MD5Context], [], [#include "include/md5.h"]) AC_SUBST(EXTRA_LIBS) AC_CONFIG_FILES([base.buildinfo]) diff --git a/include/CTypes.h b/include/CTypes.h --- a/include/CTypes.h +++ b/include/CTypes.h @@ -16,7 +16,7 @@ -- // GHC can derive any class for a newtype, so we make use of that here... -#define ARITHMETIC_CLASSES Eq,Ord,Num,Enum,Storable,Real,Typeable +#define ARITHMETIC_CLASSES Eq,Ord,Num,Enum,Storable,Real #define INTEGRAL_CLASSES Bounded,Integral,Bits,FiniteBits #define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat diff --git a/include/HsBase.h b/include/HsBase.h --- a/include/HsBase.h +++ b/include/HsBase.h @@ -86,7 +86,7 @@ #if HAVE_SYS_TIMES_H #include #endif -#if HAVE_WINSOCK_H && defined(__MINGW32__) +#if HAVE_WINSOCK_H && defined(_WIN32) #include #endif #if HAVE_LIMITS_H @@ -111,7 +111,7 @@ # include #endif -#if !defined(__MINGW32__) && !defined(irix_HOST_OS) +#if !defined(_WIN32) && !defined(irix_HOST_OS) # if HAVE_SYS_RESOURCE_H # include # endif @@ -134,14 +134,14 @@ #endif #include "WCsubst.h" -#if defined(__MINGW32__) +#if defined(_WIN32) /* in Win32Utils.c */ extern void maperrno (void); extern int maperrno_func(DWORD dwErrorCode); extern HsWord64 getMonotonicUSec(void); #endif -#if defined(__MINGW32__) +#if defined(_WIN32) #include #include #include @@ -298,14 +298,14 @@ INLINE int __hscore_setmode( int fd, HsBool toBin ) { -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) - return setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT); +#if defined(_WIN32) + return _setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT); #else return 0; #endif } -#if defined(__MINGW32__) +#if defined(_WIN32) // We want the versions of stat/fstat/lseek that use 64-bit offsets, // and you have to ask for those explicitly. Unfortunately there // doesn't seem to be a 64-bit version of truncate/ftruncate, so while @@ -331,7 +331,7 @@ INLINE ino_t __hscore_st_ino ( struct_stat* st ) { return st->st_ino; } #endif -#if defined(__MINGW32__) +#if defined(_WIN32) INLINE int __hscore_stat(wchar_t *file, struct_stat *buf) { return _wstati64(file,buf); } @@ -375,7 +375,7 @@ INLINE HsInt __hscore_sizeof_termios( void ) { -#ifndef __MINGW32__ +#ifndef _WIN32 return sizeof(struct termios); #else return 0; @@ -383,7 +383,7 @@ } #endif -#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32) +#if !defined(_WIN32) INLINE HsInt __hscore_sizeof_sigset_t( void ) { @@ -468,7 +468,7 @@ #endif } -#ifndef __MINGW32__ +#ifndef _WIN32 INLINE size_t __hscore_sizeof_siginfo_t (void) { return sizeof(siginfo_t); @@ -519,7 +519,7 @@ extern void* __hscore_get_saved_termios(int fd); extern void __hscore_set_saved_termios(int fd, void* ts); -#ifdef __MINGW32__ +#ifdef _WIN32 INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) { if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND)) return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode); diff --git a/include/HsBaseConfig.h.in b/include/HsBaseConfig.h.in --- a/include/HsBaseConfig.h.in +++ b/include/HsBaseConfig.h.in @@ -612,6 +612,28 @@ /* Define if stdlib.h declares unsetenv to return void. */ #undef UNSETENV_RETURNS_VOID +/* Enable extensions on AIX 3, Interix. */ +#ifndef _ALL_SOURCE +# undef _ALL_SOURCE +#endif +/* Enable GNU extensions on systems that have them. */ +#ifndef _GNU_SOURCE +# undef _GNU_SOURCE +#endif +/* Enable threading extensions on Solaris. */ +#ifndef _POSIX_PTHREAD_SEMANTICS +# undef _POSIX_PTHREAD_SEMANTICS +#endif +/* Enable extensions on HP NonStop. */ +#ifndef _TANDEM_SOURCE +# undef _TANDEM_SOURCE +#endif +/* Enable general extensions on Solaris. */ +#ifndef __EXTENSIONS__ +# undef __EXTENSIONS__ +#endif + + /* Enable large inode numbers on Mac OS X 10.5. */ #ifndef _DARWIN_USE_64_BIT_INODE # define _DARWIN_USE_64_BIT_INODE 1 @@ -622,3 +644,13 @@ /* Define for large files, on AIX-style hosts. */ #undef _LARGE_FILES + +/* Define to 1 if on MINIX. */ +#undef _MINIX + +/* Define to 2 if the system does not provide POSIX.1 features except with + this defined. */ +#undef _POSIX_1_SOURCE + +/* Define to 1 if you need to in order for `stat' and other things to work. */ +#undef _POSIX_SOURCE diff --git a/include/Typeable.h b/include/Typeable.h deleted file mode 100644 --- a/include/Typeable.h +++ /dev/null @@ -1,31 +0,0 @@ -{- -------------------------------------------------------------------------- -// Macros to help make Typeable instances. -// -// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines -// -// instance Typeable/n/ tc -// instance Typeable a => Typeable/n-1/ (tc a) -// instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) -// ... -// instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) -// -------------------------------------------------------------------------- --} - -#ifndef TYPEABLE_H -#define TYPEABLE_H - -#warning is obsolete and will be removed in GHC 7.10 - --- // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to --- // generate the instances. - -#define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE4(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE5(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE6(tycon,tcname,str) deriving instance Typeable tycon -#define INSTANCE_TYPEABLE7(tycon,tcname,str) deriving instance Typeable tycon - -#endif