packages feed

base 4.16.4.0 → 4.22.0.0

raw patch · 589 files changed

Files

− Control/Applicative.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Applicative--- 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------ This module describes a structure intermediate between a functor and--- a monad (technically, a strong lax monoidal functor).  Compared with--- monads, this interface lacks the full power of the binding operation--- '>>=', but------ * it has more instances.------ * it is sufficient for many uses, e.g. context-free parsing, or the---   'Data.Traversable.Traversable' class.------ * instances can perform analysis of computations before they are---   executed, and thus produce shared optimizations.------ This interface was introduced for parsers by Niklas R&#xF6;jemo, because--- it admits more sharing than the monadic interface.  The names here are--- mostly based on parsing work by Doaitse Swierstra.------ For more details, see--- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,--- by Conor McBride and Ross Paterson.--module Control.Applicative (-    -- * Applicative functors-    Applicative(..),-    -- * Alternatives-    Alternative(..),-    -- * Instances-    Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),-    -- * Utility functions-    (<$>), (<$), (<**>),-    liftA, liftA3,-    optional,-    asum,-    ) where--import Control.Category hiding ((.), id)-import Control.Arrow-import Data.Maybe-import Data.Tuple-import Data.Eq-import Data.Ord-import Data.Foldable (Foldable(..), asum)-import Data.Functor ((<$>))-import Data.Functor.Const (Const(..))--import GHC.Base-import GHC.Generics-import GHC.List (repeat, zipWith, drop)-import GHC.Read (Read)-import GHC.Show (Show)---- $setup--- >>> import Prelude--newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }-                         deriving ( Generic  -- ^ @since 4.7.0.0-                                  , Generic1 -- ^ @since 4.7.0.0-                                  , Monad    -- ^ @since 4.7.0.0-                                  )---- | @since 2.01-instance Monad m => Functor (WrappedMonad m) where-    fmap f (WrapMonad v) = WrapMonad (liftM f v)---- | @since 2.01-instance Monad m => Applicative (WrappedMonad m) where-    pure = WrapMonad . pure-    WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)-    liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y)---- | @since 2.01-instance MonadPlus m => Alternative (WrappedMonad m) where-    empty = WrapMonad mzero-    WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)--newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }-                           deriving ( Generic  -- ^ @since 4.7.0.0-                                    , Generic1 -- ^ @since 4.7.0.0-                                    )---- | @since 2.01-instance Arrow a => Functor (WrappedArrow a b) where-    fmap f (WrapArrow a) = WrapArrow (a >>> arr f)---- | @since 2.01-instance Arrow a => Applicative (WrappedArrow a b) where-    pure x = WrapArrow (arr (const x))-    liftA2 f (WrapArrow u) (WrapArrow v) =-      WrapArrow (u &&& v >>> arr (uncurry f))---- | @since 2.01-instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where-    empty = WrapArrow zeroArrow-    WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)---- | Lists, but with an 'Applicative' functor based on zipping.-newtype ZipList a = ZipList { getZipList :: [a] }-                  deriving ( Show     -- ^ @since 4.7.0.0-                           , Eq       -- ^ @since 4.7.0.0-                           , Ord      -- ^ @since 4.7.0.0-                           , Read     -- ^ @since 4.7.0.0-                           , Functor  -- ^ @since 2.01-                           , Foldable -- ^ @since 4.9.0.0-                           , Generic  -- ^ @since 4.7.0.0-                           , Generic1 -- ^ @since 4.7.0.0-                           )--- See Data.Traversable for Traversable instance due to import loops---- |--- > f <$> ZipList xs1 <*> ... <*> ZipList xsN--- >     = ZipList (zipWithN f xs1 ... xsN)------ where @zipWithN@ refers to the @zipWith@ function of the appropriate arity--- (@zipWith@, @zipWith3@, @zipWith4@, ...). For example:------ > (\a b c -> stimes c [a, b]) <$> ZipList "abcd" <*> ZipList "567" <*> ZipList [1..]--- >     = ZipList (zipWith3 (\a b c -> stimes c [a, b]) "abcd" "567" [1..])--- >     = ZipList {getZipList = ["a5","b6b6","c7c7c7"]}------ @since 2.01-instance Applicative ZipList where-    pure x = ZipList (repeat x)-    liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)---- | @since 4.11.0.0-instance Alternative ZipList where-   empty = ZipList []-   ZipList xs <|> ZipList ys = ZipList (xs ++ drop (length xs) ys)---- extra functions---- | One or none.------ It is useful for modelling any computation that is allowed to fail.------ ==== __Examples__------ Using the 'Alternative' instance of "Control.Monad.Except", the following functions:------ >>> import Control.Monad.Except------ >>> canFail = throwError "it failed" :: Except String Int--- >>> final = return 42                :: Except String Int------ Can be combined by allowing the first function to fail:------ >>> runExcept $ canFail *> final--- Left "it failed"--- >>> runExcept $ optional canFail *> final--- Right 42--optional :: Alternative f => f a -> f (Maybe a)-optional v = Just <$> v <|> pure Nothing
− Control/Arrow.hs 
@@ -1,432 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}-    -- The RULES for the methods of class Arrow may never fire-    -- e.g. compose/arr;  see #10528---------------------------------------------------------------------------------- |--- Module      :  Control.Arrow--- Copyright   :  (c) Ross Paterson 2002--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Basic arrow definitions, based on------  * /Generalising Monads to Arrows/, by John Hughes,---    /Science of Computer Programming/ 37, pp67-111, May 2000.------ plus a couple of definitions ('returnA' and 'loop') from------  * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,---    Firenze, Italy, pp229-240.------ These papers and more information on arrows can be found at--- <http://www.haskell.org/arrows/>.--module Control.Arrow (-    -- * Arrows-    Arrow(..), Kleisli(..),-    -- ** Derived combinators-    returnA,-    (^>>), (>>^),-    (>>>), (<<<), -- reexported-    -- ** Right-to-left variants-    (<<^), (^<<),-    -- * Monoid operations-    ArrowZero(..), ArrowPlus(..),-    -- * Conditionals-    ArrowChoice(..),-    -- * Arrow application-    ArrowApply(..), ArrowMonad(..), leftApp,-    -- * Feedback-    ArrowLoop(..)-    ) where--import Data.Tuple ( fst, snd, uncurry )-import Data.Either-import Control.Monad.Fix-import Control.Category-import GHC.Base hiding ( (.), id )-import GHC.Generics (Generic, Generic1)--infixr 5 <+>-infixr 3 ***-infixr 3 &&&-infixr 2 +++-infixr 2 |||-infixr 1 ^>>, >>^-infixr 1 ^<<, <<^---- | The basic arrow class.------ Instances should satisfy the following laws:------  * @'arr' id = 'id'@------  * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@------  * @'first' ('arr' f) = 'arr' ('first' f)@------  * @'first' (f >>> g) = 'first' f >>> 'first' g@------  * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@------  * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@------  * @'first' ('first' f) >>> 'arr' assoc = 'arr' assoc >>> 'first' f@------ where------ > assoc ((a,b),c) = (a,(b,c))------ The other combinators have sensible default definitions,--- 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--    -- | 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 = (id ***)--    -- | Split the input between the two argument arrows and combine-    --   their output.  Note that this is in general not a functor.-    ---    --   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 >>> arr swap >>> first g >>> arr swap-      where swap ~(x,y) = (y,x)--    -- | Fanout: send the input to both argument arrows and combine-    --   their output.-    ---    --   The default definition may be overridden with a more efficient-    --   version if desired.-    (&&&) :: a b c -> a b c' -> a b (c,c')-    f &&& g = arr (\b -> (b,b)) >>> f *** g--{-# RULES-"compose/arr"   forall f g .-                (arr f) . (arr g) = arr (f . g)-"first/arr"     forall f .-                first (arr f) = arr (first f)-"second/arr"    forall f .-                second (arr f) = arr (second f)-"product/arr"   forall f g .-                arr f *** arr g = arr (f *** g)-"fanout/arr"    forall f g .-                arr f &&& arr g = arr (f &&& g)-"compose/first" forall f g .-                (first f) . (first g) = first (f . g)-"compose/second" forall f g .-                (second f) . (second g) = second (f . g)- #-}---- Ordinary functions are arrows.---- | @since 2.01-instance Arrow (->) where-    arr f = 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)---- | Kleisli arrows of a monad.-newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }---- | @since 4.14.0.0-deriving instance Generic (Kleisli m a b)---- | @since 4.14.0.0-deriving instance Generic1 (Kleisli m a)---- | @since 4.14.0.0-deriving instance Functor m => Functor (Kleisli m a)---- | @since 4.14.0.0-instance Applicative m => Applicative (Kleisli m a) where-  pure = Kleisli . const . pure-  {-# INLINE pure #-}-  Kleisli f <*> Kleisli g = Kleisli $ \x -> f x <*> g x-  {-# INLINE (<*>) #-}-  Kleisli f *> Kleisli g = Kleisli $ \x -> f x *> g x-  {-# INLINE (*>) #-}-  Kleisli f <* Kleisli g = Kleisli $ \x -> f x <* g x-  {-# INLINE (<*) #-}---- | @since 4.14.0.0-instance Alternative m => Alternative (Kleisli m a) where-  empty = Kleisli $ const empty-  {-# INLINE empty #-}-  Kleisli f <|> Kleisli g = Kleisli $ \x -> f x <|> g x-  {-# INLINE (<|>) #-}---- | @since 4.14.0.0-instance Monad m => Monad (Kleisli m a) where-  Kleisli f >>= k = Kleisli $ \x -> f x >>= \a -> runKleisli (k a) x-  {-# INLINE (>>=) #-}---- | @since 4.14.0.0-instance MonadPlus m => MonadPlus (Kleisli m a) where-  mzero = Kleisli $ const mzero-  {-# INLINE mzero #-}-  Kleisli f `mplus` Kleisli g = Kleisli $ \x -> f x `mplus` g x-  {-# INLINE mplus #-}---- | @since 3.0-instance Monad m => Category (Kleisli m) where-    id = Kleisli return-    (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)---- | @since 2.01-instance Monad m => Arrow (Kleisli m) where-    arr f = Kleisli (return . f)-    first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d))-    second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))---- | The identity arrow, which plays the role of 'return' in arrow notation.-returnA :: Arrow a => a b b-returnA = arr id---- | Precomposition with a pure function.-(^>>) :: Arrow a => (b -> c) -> a c d -> a b d-f ^>> a = arr f >>> a---- | Postcomposition with a pure function.-(>>^) :: Arrow a => a b c -> (c -> d) -> a b d-a >>^ f = a >>> arr f---- | Precomposition with a pure function (right-to-left variant).-(<<^) :: Arrow a => a c d -> (b -> c) -> a b d-a <<^ f = a <<< arr f---- | Postcomposition with a pure function (right-to-left variant).-(^<<) :: Arrow a => (c -> d) -> a b c -> a b d-f ^<< a = arr f <<< a--class Arrow a => ArrowZero a where-    zeroArrow :: a b c---- | @since 2.01-instance MonadPlus m => ArrowZero (Kleisli m) where-    zeroArrow = Kleisli (\_ -> mzero)---- | A monoid on arrows.-class ArrowZero a => ArrowPlus a where-    -- | An associative operation with identity 'zeroArrow'.-    (<+>) :: a b c -> a b c -> a b c---- | @since 2.01-instance MonadPlus m => ArrowPlus (Kleisli m) where-    Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)---- | Choice, for arrows that support it.  This class underlies the--- @if@ and @case@ constructs in arrow notation.------ Instances should satisfy the following laws:------  * @'left' ('arr' f) = 'arr' ('left' f)@------  * @'left' (f >>> g) = 'left' f >>> 'left' g@------  * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@------  * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@------  * @'left' ('left' f) >>> 'arr' assocsum = 'arr' assocsum >>> 'left' f@------ where------ > assocsum (Left (Left x)) = Left x--- > assocsum (Left (Right y)) = Right (Left y)--- > assocsum (Right z) = Right (Right z)------ The other combinators have sensible default definitions, which may--- 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 = (id +++)--    -- | Split the input between the two argument arrows, retagging-    --   and merging their outputs.-    --   Note that this is in general not a functor.-    ---    --   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 >>> 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.-    ---    --   The default definition may be overridden with a more efficient-    --   version if desired.-    (|||) :: a b d -> a c d -> a (Either b c) d-    f ||| g = f +++ g >>> arr untag-      where-        untag (Left x) = x-        untag (Right y) = y--{-# RULES-"left/arr"      forall f .-                left (arr f) = arr (left f)-"right/arr"     forall f .-                right (arr f) = arr (right f)-"sum/arr"       forall f g .-                arr f +++ arr g = arr (f +++ g)-"fanin/arr"     forall f g .-                arr f ||| arr g = arr (f ||| g)-"compose/left"  forall f g .-                left f . left g = left (f . g)-"compose/right" forall f g .-                right f . right g = right (f . g)- #-}---- | @since 2.01-instance ArrowChoice (->) where-    left f = f +++ id-    right f = id +++ f-    f +++ g = (Left . f) ||| (Right . g)-    (|||) = either---- | @since 2.01-instance Monad m => ArrowChoice (Kleisli m) where-    left f = f +++ arr id-    right f = arr id +++ f-    f +++ g = (f >>> arr Left) ||| (g >>> arr Right)-    Kleisli f ||| Kleisli g = Kleisli (either f g)---- | Some arrows allow application of arrow inputs to other inputs.--- Instances should satisfy the following laws:------  * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@------  * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@------  * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@------ Such arrows are equivalent to monads (see 'ArrowMonad').--class Arrow a => ArrowApply a where-    app :: a (a b c, b) c---- | @since 2.01-instance ArrowApply (->) where-    app (f,x) = f x---- | @since 2.01-instance Monad m => ArrowApply (Kleisli m) where-    app = Kleisli (\(Kleisli f, x) -> f x)---- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise---   to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.--newtype ArrowMonad a b = ArrowMonad (a () b)---- | @since 4.6.0.0-instance Arrow a => Functor (ArrowMonad a) where-    fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f---- | @since 4.6.0.0-instance Arrow a => Applicative (ArrowMonad a) where-   pure x = ArrowMonad (arr (const x))-   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))---- | @since 2.01-instance ArrowApply a => Monad (ArrowMonad a) where-    ArrowMonad m >>= f = ArrowMonad $-        m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app---- | @since 4.6.0.0-instance ArrowPlus a => Alternative (ArrowMonad a) where-   empty = ArrowMonad zeroArrow-   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)---- | @since 4.6.0.0-instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a)---- | Any instance of 'ArrowApply' can be made into an instance of---   'ArrowChoice' by defining 'left' = 'leftApp'.--leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)-leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||-             (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app---- | The 'loop' operator expresses computations in which an output value--- is fed back as input, although the computation occurs only once.--- It underlies the @rec@ value recursion construct in arrow notation.--- 'loop' should satisfy the following laws:------ [/extension/]---      @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@------ [/left tightening/]---      @'loop' ('first' h >>> f) = h >>> 'loop' f@------ [/right tightening/]---      @'loop' (f >>> 'first' h) = 'loop' f >>> h@------ [/sliding/]---      @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@------ [/vanishing/]---      @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@------ [/superposing/]---      @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@------ where------ > assoc ((a,b),c) = (a,(b,c))--- > unassoc (a,(b,c)) = ((a,b),c)----class Arrow a => ArrowLoop a where-    loop :: a (b,d) (c,d) -> a b c---- | @since 2.01-instance ArrowLoop (->) where-    loop f b = let (c,d) = f (b,d) in c---- | Beware that for many monads (those for which the '>>=' operation--- is strict) this instance will /not/ satisfy the right-tightening law--- required by the 'ArrowLoop' class.------ @since 2.01-instance MonadFix m => ArrowLoop (Kleisli m) where-    loop (Kleisli f) = Kleisli (liftM fst . mfix . f')-      where f' x y = f (x, snd y)
− Control/Category.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# 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 #10528---------------------------------------------------------------------------------- |--- Module      :  Control.Category--- Copyright   :  (c) Ashley Yakeley 2007--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  ashley@semantic.org--- Stability   :  experimental--- Portability :  portable---- https://gitlab.haskell.org/ghc/ghc/issues/1773--module Control.Category where--import qualified GHC.Base (id,(.))-import Data.Type.Coercion-import Data.Type.Equality-import Data.Coerce (coerce)--infixr 9 .-infixr 1 >>>, <<<---- | A class for categories. Instances should satisfy the laws------ [Right identity] @f '.' 'id'  =  f@--- [Left identity]  @'id' '.' f  =  f@--- [Associativity]  @f '.' (g '.' h)  =  (f '.' g) '.' h@----class Category cat where-    -- | the identity morphism-    id :: cat a a--    -- | morphism composition-    (.) :: cat b c -> cat a b -> cat a c--{-# RULES-"identity/left" forall p .-                id . p = p-"identity/right"        forall p .-                p . id = p-"association"   forall p q r .-                (p . q) . r = p . (q . r)- #-}---- | @since 3.0-instance Category (->) where-    id = GHC.Base.id-    (.) = (GHC.Base..)---- | @since 4.7.0.0-instance Category (:~:) where-  id          = Refl-  Refl . Refl = Refl---- | @since 4.10.0.0-instance Category (:~~:) where-  id            = HRefl-  HRefl . HRefl = HRefl---- | @since 4.7.0.0-instance Category Coercion where-  id = Coercion-  (.) Coercion = coerce---- | Right-to-left composition-(<<<) :: Category cat => cat b c -> cat a b -> cat a c-(<<<) = (.)---- | Left-to-right composition-(>>>) :: Category cat => cat a b -> cat b c -> cat a c-f >>> g = g . f-{-# INLINE (>>>) #-} -- see Note [INLINE on >>>]--{- Note [INLINE on >>>]-~~~~~~~~~~~~~~~~~~~~~~~-It’s crucial that we include an INLINE pragma on >>>, which may be-surprising. After all, its unfolding is tiny, so GHC will be extremely-keen to inline it even without the pragma. Indeed, it is actually-/too/ keen: unintuitively, the pragma is needed to rein in inlining,-not to encourage it.--How is that possible? The difference lies entirely in whether GHC will-inline unsaturated calls. With no pragma at all, we get the following-unfolding guidance:-    ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)-But with the pragma, we restrict inlining to saturated calls:-    ALWAYS_IF(arity=3,unsat_ok=False,boring_ok=True)-Why does this matter? Because the programmer may have put an INLINE-pragma on (.):--    instance Functor f => Category (Blah f) where-      id = ...-      Blah f . Blah g = buildBlah (\x -> ...)-      {-# INLINE (.) #-}--The intent here is to inline (.) at all saturated call sites. Perhaps-there is a RULE on buildBlah the programmer wants to fire, or maybe-they just expect the inlining to expose further simplifications.-Either way, code that uses >>> should not defeat this inlining, but if-we inline unsaturated calls, it might! Consider:--    let comp = (>>>) ($fCategoryBlah $dFunctor) in f `comp` (g `comp` h)--While simplifying this expression, we’ll start with the RHS of comp.-Without the INLINE pragma on >>>, we’ll inline it immediately, even-though it isn’t saturated:--    let comp = \f g -> $fCategoryBlah_$c. $dFunctor g f-     in f `comp` (g `comp` h)--Now `$fCategoryBlah_$c. $dFunctor g f` /is/ a fully-saturated call, so-it will get inlined immediately, too:--    let comp = \(Blah g) (Blah f) -> buildBlah (\x -> ...)-     in f `comp` (g `comp` h)--All okay so far. But if the RHS of (.) is large, comp won’t be inlined-at its use sites, and any RULEs on `buildBlah` will never fire. Bad!--What happens differently with the INLINE pragma on >>>? Well, we won’t-inline >>> immediately, since it isn’t saturated, which means comp’s-unfolding will be tiny. GHC will inline it at both use sites:--    (>>>) ($fCategoryBlah $dFunctor) f-          ((>>>) ($fCategoryBlah $dFunctor) g h)--And now the calls to >>> are saturated, so they’ll be inlined,-followed by (.), and any RULEs can fire as desired. Problem solved.--This situation might seem academic --- who would ever write a-definition like comp? Probably nobody, but GHC generates such-definitions when desugaring proc notation, which causes real problems-(see #18013). That could be fixed by changing the proc desugaring, but-fixing it this way is the Right Thing, it might benefit other programs-in more subtle ways too, and it’s easier to boot. -}
− Control/Concurrent.hs 
@@ -1,666 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , MagicHash-           , UnboxedTuples-           , ScopedTypeVariables-           , RankNTypes-  #-}-{-# OPTIONS_GHC -Wno-deprecations #-}--- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN--- and Control.Concurrent.SampleVar imports.---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (concurrency)------ A common interface to a collection of useful concurrency--- abstractions.-----------------------------------------------------------------------------------module Control.Concurrent (-        -- * Concurrent Haskell--        -- $conc_intro--        -- * Basic concurrency operations--        ThreadId,-        myThreadId,--        forkIO,-        forkFinally,-        forkIOWithUnmask,-        killThread,-        throwTo,--        -- ** Threads with affinity-        forkOn,-        forkOnWithUnmask,-        getNumCapabilities,-        setNumCapabilities,-        threadCapability,--        -- * Scheduling--        -- $conc_scheduling-        yield,--        -- ** Blocking--        -- $blocking--        -- ** Waiting-        threadDelay,-        threadWaitRead,-        threadWaitWrite,-        threadWaitReadSTM,-        threadWaitWriteSTM,--        -- * Communication abstractions--        module Control.Concurrent.MVar,-        module Control.Concurrent.Chan,-        module Control.Concurrent.QSem,-        module Control.Concurrent.QSemN,--        -- * Bound Threads-        -- $boundthreads-        rtsSupportsBoundThreads,-        forkOS,-        forkOSWithUnmask,-        isCurrentThreadBound,-        runInBoundThread,-        runInUnboundThread,--        -- * Weak references to ThreadIds-        mkWeakThreadId,--        -- * GHC's implementation of concurrency--        -- |This section describes features specific to GHC's-        -- implementation of Concurrent Haskell.--        -- ** Haskell threads and Operating System threads--        -- $osthreads--        -- ** Terminating the program--        -- $termination--        -- ** Pre-emption--        -- $preemption--        -- ** Deadlock--        -- $deadlock--    ) where--import Control.Exception.Base as Exception--import GHC.Conc hiding (threadWaitRead, threadWaitWrite,-                        threadWaitReadSTM, threadWaitWriteSTM)-import GHC.IO           ( unsafeUnmask, catchException )-import GHC.IORef        ( newIORef, readIORef, writeIORef )-import GHC.Base--import System.Posix.Types ( Fd )-import Foreign.StablePtr-import Foreign.C.Types--#if defined(mingw32_HOST_OS)-import Foreign.C-import System.IO-import Data.Functor ( void )-import Data.Int ( Int64 )-#else-import qualified GHC.Conc-#endif--import Control.Concurrent.MVar-import Control.Concurrent.Chan-import Control.Concurrent.QSem-import Control.Concurrent.QSemN--{- $conc_intro--The concurrency extension for Haskell is described in the paper-/Concurrent Haskell/-<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.--Concurrency is \"lightweight\", which means that both thread creation-and context switching overheads are extremely low.  Scheduling of-Haskell threads is done internally in the Haskell runtime system, and-doesn't make use of any operating system-supplied thread packages.--However, if you want to interact with a foreign library that expects your-program to use the operating system-supplied thread package, you can do so-by using 'forkOS' instead of 'forkIO'.--Haskell threads can communicate via 'MVar's, a kind of synchronised-mutable variable (see "Control.Concurrent.MVar").  Several common-concurrency abstractions can be built from 'MVar's, and these are-provided by the "Control.Concurrent" library.-In GHC, threads may also communicate via exceptions.--}--{- $conc_scheduling--    Scheduling may be either pre-emptive or co-operative,-    depending on the implementation of Concurrent Haskell (see below-    for information related to specific compilers).  In a co-operative-    system, context switches only occur when you use one of the-    primitives defined in this module.  This means that programs such-    as:--->   main = forkIO (write 'a') >> write 'b'->     where write c = putChar c >> write c--    will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,-    instead of some random interleaving of @a@s and @b@s.  In-    practice, cooperative multitasking is sufficient for writing-    simple graphical user interfaces.--}--{- $blocking-Different Haskell implementations have different characteristics with-regard to which operations block /all/ threads.--Using GHC without the @-threaded@ option, all foreign calls will block-all other Haskell threads in the system, although I\/O operations will-not.  With the @-threaded@ option, only foreign calls with the @unsafe@-attribute will block all other threads.---}---- | 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.------ > forkFinally action and_then =--- >   mask $ \restore ->--- >     forkIO $ try (restore action) >>= and_then------ This function is useful for informing the parent when a child--- terminates, for example.------ @since 4.6.0.0-forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkFinally action and_then =-  mask $ \restore ->-    forkIO $ try (restore action) >>= and_then---- ------------------------------------------------------------------------------ Bound Threads--{- $boundthreads-   #boundthreads#--Support for multiple operating system threads and bound threads as described-below is currently only available in the GHC runtime system if you use the-/-threaded/ option when linking.--Other Haskell systems do not currently support multiple operating system threads.--A bound thread is a haskell thread that is /bound/ to an operating system-thread. While the bound thread is still scheduled by the Haskell run-time-system, the operating system thread takes care of all the foreign calls made-by the bound thread.--To a foreign library, the bound thread will look exactly like an ordinary-operating system thread created using OS functions like @pthread_create@-or @CreateThread@.--Bound threads can be created using the 'forkOS' function below. All foreign-exported functions are run in a bound thread (bound to the OS thread that-called the function). Also, the @main@ action of every Haskell program is-run in a bound thread.--Why do we need this? Because if a foreign library is called from a thread-created using 'forkIO', it won't have access to any /thread-local state/ --state variables that have specific values for each OS thread-(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some-libraries (OpenGL, for example) will not work from a thread created using-'forkIO'. They work fine in threads created using 'forkOS' or when called-from @main@ or from a @foreign export@.--In terms of performance, 'forkOS' (aka bound) threads are much more-expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'-thread is tied to a particular OS thread, whereas a 'forkIO' thread-can be run by any OS thread.  Context-switching between a 'forkOS'-thread and a 'forkIO' thread is many times more expensive than between-two 'forkIO' threads.--Note in particular that the main program thread (the thread running-@Main.main@) is always a bound thread, so for good concurrency-performance you should ensure that the main thread is not doing-repeated communication with other threads in the system.  Typically-this means forking subthreads to do the work using 'forkIO', and-waiting for the results in the main thread.---}---- | 'True' if bound threads are supported.--- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'--- will always return 'False' and both 'forkOS' and 'runInBoundThread' will--- fail.-foreign import ccall unsafe rtsSupportsBoundThreads :: Bool---{- |-Like 'forkIO', this sparks off a new thread to run the 'IO'-computation passed as the first argument, and returns the 'ThreadId'-of the newly created thread.--However, 'forkOS' creates a /bound/ thread, which is necessary if you-need to call foreign (non-Haskell) libraries that make use of-thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads").--Using 'forkOS' instead of 'forkIO' makes no difference at all to the-scheduling behaviour of the Haskell runtime system.  It is a common-misconception that you need to use 'forkOS' instead of 'forkIO' to-avoid blocking all the Haskell threads when making a foreign call;-this isn't the case.  To allow foreign calls to be made without-blocking all the Haskell threads (with GHC), it is only necessary to-use the @-threaded@ option when linking your program, and to make sure-the foreign import is not marked @unsafe@.--}--forkOS :: IO () -> IO ThreadId--foreign export ccall forkOS_entry-    :: StablePtr (IO ()) -> IO ()--foreign import ccall "forkOS_entry" forkOS_entry_reimported-    :: StablePtr (IO ()) -> IO ()--forkOS_entry :: StablePtr (IO ()) -> IO ()-forkOS_entry stableAction = do-        action <- deRefStablePtr stableAction-        action--foreign import ccall forkOS_createThread-    :: StablePtr (IO ()) -> IO CInt--failNonThreaded :: IO a-failNonThreaded = fail $ "RTS doesn't support multiple OS threads "-                       ++"(use ghc -threaded when linking)"--forkOS action0-    | rtsSupportsBoundThreads = do-        mv <- newEmptyMVar-        b <- Exception.getMaskingState-        let-            -- async exceptions are masked in the child if they are masked-            -- in the parent, as for forkIO (see #1048). forkOS_createThread-            -- creates a thread with exceptions masked by default.-            action1 = case b of-                        Unmasked -> unsafeUnmask action0-                        MaskedInterruptible -> action0-                        MaskedUninterruptible -> uninterruptibleMask_ action0--            action_plus = catch action1 childHandler--        entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)-        err <- forkOS_createThread entry-        when (err /= 0) $ fail "Cannot create OS thread."-        tid <- takeMVar mv-        freeStablePtr entry-        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.-isCurrentThreadBound :: IO Bool-isCurrentThreadBound = IO $ \ s# ->-    case isCurrentThreadBound# s# of-        (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)---{- |-Run the 'IO' computation passed as the first argument. If the calling thread-is not /bound/, a bound thread is created temporarily. @runInBoundThread@-doesn't finish until the 'IO' computation finishes.--You can wrap a series of foreign function calls that rely on thread-local state-with @runInBoundThread@ so that you can use them without knowing whether the-current thread is /bound/.--}-runInBoundThread :: IO a -> IO a--runInBoundThread action-    | rtsSupportsBoundThreads = do-        bound <- isCurrentThreadBound-        if bound-            then action-            else do-                ref <- newIORef undefined-                let action_plus = Exception.try action >>= writeIORef ref-                bracket (newStablePtr action_plus)-                        freeStablePtr-                        (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=-                  unsafeResult-    | otherwise = failNonThreaded--{- |-Run the 'IO' computation passed as the first argument. If the calling thread-is /bound/, an unbound thread is created temporarily using 'forkIO'.-@runInBoundThread@ doesn't finish until the 'IO' computation finishes.--Use this function /only/ in the rare case that you have actually observed a-performance loss due to the use of bound threads. A program that-doesn't need its main thread to be bound and makes /heavy/ use of concurrency-(e.g. a web server), might want to wrap its @main@ action in-@runInUnboundThread@.--Note that exceptions which are thrown to the current thread are thrown in turn-to the thread that is executing the given computation. This ensures there's-always a way of killing the forked thread.--}-runInUnboundThread :: IO a -> IO a--runInUnboundThread action = do-  bound <- isCurrentThreadBound-  if bound-    then do-      mv <- newEmptyMVar-      mask $ \restore -> do-        tid <- forkIO $ Exception.try (restore action) >>= putMVar mv-        let wait = takeMVar mv `catchException` \(e :: SomeException) ->-                     Exception.throwTo tid e >> wait-        wait >>= unsafeResult-    else action--unsafeResult :: Either SomeException a -> IO a-unsafeResult = either Exception.throwIO return---- ------------------------------------------------------------------------------ threadWaitRead/threadWaitWrite---- | Block the current thread until data is available to read on the--- given file descriptor (GHC only).------ This will throw an 'IOError' if the file descriptor was closed--- while this thread was blocked.  To safely close a file descriptor--- that has been used with 'threadWaitRead', use--- 'GHC.Conc.closeFdWith'.-threadWaitRead :: Fd -> IO ()-threadWaitRead fd-#if defined(mingw32_HOST_OS)-  -- we have no IO manager implementing threadWaitRead on Windows.-  -- fdReady does the right thing, but we have to call it in a-  -- separate thread, otherwise threadWaitRead won't be interruptible,-  -- and this only works with -threaded.-  | threaded  = withThread (waitFd fd False)-  | otherwise = case fd of-                  0 -> do _ <- hWaitForInput stdin (-1)-                          return ()-                        -- hWaitForInput does work properly, but we can only-                        -- do this for stdin since we know its FD.-                  _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"-#else-  = GHC.Conc.threadWaitRead fd-#endif---- | Block the current thread until data can be written to the--- given file descriptor (GHC only).------ This will throw an 'IOError' if the file descriptor was closed--- while this thread was blocked.  To safely close a file descriptor--- that has been used with 'threadWaitWrite', use--- 'GHC.Conc.closeFdWith'.-threadWaitWrite :: Fd -> IO ()-threadWaitWrite fd-#if defined(mingw32_HOST_OS)-  | threaded  = withThread (waitFd fd True)-  | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows"-#else-  = GHC.Conc.threadWaitWrite fd-#endif---- | Returns an STM action that can be used to wait for data--- to read from a file descriptor. The second returned value--- is an IO action that can be used to deregister interest--- in the file descriptor.------ @since 4.7.0.0-threadWaitReadSTM :: Fd -> IO (STM (), IO ())-threadWaitReadSTM fd-#if defined(mingw32_HOST_OS)-  | threaded = do v <- newTVarIO Nothing-                  mask_ $ void $ forkIO $ do result <- try (waitFd fd False)-                                             atomically (writeTVar v $ Just result)-                  let waitAction = do result <- readTVar v-                                      case result of-                                        Nothing         -> retry-                                        Just (Right ()) -> return ()-                                        Just (Left e)   -> throwSTM (e :: IOException)-                  let killAction = return ()-                  return (waitAction, killAction)-  | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows"-#else-  = GHC.Conc.threadWaitReadSTM fd-#endif---- | Returns an STM action that can be used to wait until data--- can be written to a file descriptor. The second returned value--- is an IO action that can be used to deregister interest--- in the file descriptor.------ @since 4.7.0.0-threadWaitWriteSTM :: Fd -> IO (STM (), IO ())-threadWaitWriteSTM fd-#if defined(mingw32_HOST_OS)-  | threaded = do v <- newTVarIO Nothing-                  mask_ $ void $ forkIO $ do result <- try (waitFd fd True)-                                             atomically (writeTVar v $ Just result)-                  let waitAction = do result <- readTVar v-                                      case result of-                                        Nothing         -> retry-                                        Just (Right ()) -> return ()-                                        Just (Left e)   -> throwSTM (e :: IOException)-                  let killAction = return ()-                  return (waitAction, killAction)-  | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows"-#else-  = GHC.Conc.threadWaitWriteSTM fd-#endif--#if defined(mingw32_HOST_OS)-foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool--withThread :: IO a -> IO a-withThread io = do-  m <- newEmptyMVar-  _ <- mask_ $ forkIO $ try io >>= putMVar m-  x <- takeMVar m-  case x of-    Right a -> return a-    Left e  -> throwIO (e :: IOException)--waitFd :: Fd -> Bool -> IO ()-waitFd fd write = do-   throwErrnoIfMinus1_ "fdReady" $-        fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0--foreign import ccall safe "fdReady"-  fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt-#endif---- ------------------------------------------------------------------------------ More docs--{- $osthreads--      #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and-      are managed entirely by the GHC runtime.  Typically Haskell-      threads are an order of magnitude or two more efficient (in-      terms of both time and space) than operating system threads.--      The downside of having lightweight threads is that only one can-      run at a time, so if one thread blocks in a foreign call, for-      example, the other threads cannot continue.  The GHC runtime-      works around this by making use of full OS threads where-      necessary.  When the program is built with the @-threaded@-      option (to link against the multithreaded version of the-      runtime), a thread making a @safe@ foreign call will not block-      the other threads in the system; another OS thread will take-      over running Haskell threads until the original call returns.-      The runtime maintains a pool of these /worker/ threads so that-      multiple Haskell threads can be involved in external calls-      simultaneously.--      The "System.IO" library manages multiplexing in its own way.  On-      Windows systems it uses @safe@ foreign calls to ensure that-      threads doing I\/O operations don't block the whole runtime,-      whereas on Unix systems all the currently blocked I\/O requests-      are managed by a single thread (the /IO manager thread/) using-      a mechanism such as @epoll@ or @kqueue@, depending on what is-      provided by the host operating system.--      The runtime will run a Haskell thread using any of the available-      worker OS threads.  If you need control over which particular OS-      thread is used to run a given Haskell thread, perhaps because-      you need to call a foreign library that uses OS-thread-local-      state, then you need bound threads (see "Control.Concurrent#boundthreads").--      If you don't use the @-threaded@ option, then the runtime does-      not make use of multiple OS threads.  Foreign calls will block-      all other running Haskell threads until the call returns.  The-      "System.IO" library still does multiplexing, so there can be multiple-      threads doing I\/O, and this is handled internally by the runtime using-      @select@.--}--{- $termination--      In a standalone GHC program, only the main thread is-      required to terminate in order for the process to terminate.-      Thus all other forked threads will simply terminate at the same-      time as the main thread (the terminology for this kind of-      behaviour is \"daemonic threads\").--      If you want the program to wait for child threads to-      finish before exiting, you need to program this yourself.  A-      simple mechanism is to have each child thread write to an-      'MVar' when it completes, and have the main-      thread wait on all the 'MVar's before-      exiting:-->   myForkIO :: IO () -> IO (MVar ())->   myForkIO io = do->     mvar <- newEmptyMVar->     forkFinally io (\_ -> putMVar mvar ())->     return mvar--      Note that we use 'forkFinally' to make sure that the-      'MVar' is written to even if the thread dies or-      is killed for some reason.--      A better method is to keep a global list of all child-      threads which we should wait for at the end of the program:-->    children :: MVar [MVar ()]->    children = unsafePerformIO (newMVar [])->->    waitForChildren :: IO ()->    waitForChildren = do->      cs <- takeMVar children->      case cs of->        []   -> return ()->        m:ms -> do->           putMVar children ms->           takeMVar m->           waitForChildren->->    forkChild :: IO () -> IO ThreadId->    forkChild io = do->        mvar <- newEmptyMVar->        childs <- takeMVar children->        putMVar children (mvar:childs)->        forkFinally io (\_ -> putMVar mvar ())->->     main =->       later waitForChildren $->       ...--      The main thread principle also applies to calls to Haskell from-      outside, using @foreign export@.  When the @foreign export@ed-      function is invoked, it starts a new main thread, and it returns-      when this main thread terminates.  If the call causes new-      threads to be forked, they may remain in the system after the-      @foreign export@ed function has returned.--}--{- $preemption--      GHC implements pre-emptive multitasking: the execution of-      threads are interleaved in a random fashion.  More specifically,-      a thread may be pre-empted whenever it allocates some memory,-      which unfortunately means that tight loops which do no-      allocation tend to lock out other threads (this only seems to-      happen with pathological benchmark-style code, however).--      The rescheduling timer runs on a 20ms granularity by-      default, but this may be altered using the-      @-i\<n\>@ RTS option.  After a rescheduling-      \"tick\" the running thread is pre-empted as soon as-      possible.--      One final note: the-      @aaaa@ @bbbb@ example may not-      work too well on GHC (see Scheduling, above), due-      to the locking on a 'System.IO.Handle'.  Only one thread-      may hold the lock on a 'System.IO.Handle' at any one-      time, so if a reschedule happens while a thread is holding the-      lock, the other thread won't be able to run.  The upshot is that-      the switch from @aaaa@ to-      @bbbbb@ happens infrequently.  It can be-      improved by lowering the reschedule tick period.  We also have a-      patch that causes a reschedule whenever a thread waiting on a-      lock is woken up, but haven't found it to be useful for anything-      other than this example :-)--}--{- $deadlock--GHC attempts to detect when threads are deadlocked using the garbage-collector.  A thread that is not reachable (cannot be found by-following pointers from live objects) must be deadlocked, and in this-case the thread is sent an exception.  The exception is either-'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM',-'NonTermination', or 'Deadlock', depending on the way in which the-thread is deadlocked.--Note that this feature is intended for debugging, and should not be-relied on for the correct operation of your program.  There is no-guarantee that the garbage collector will be accurate enough to detect-your deadlock, and no guarantee that the garbage collector will run in-a timely enough manner.  Basically, the same caveats as for finalizers-apply to deadlock detection.--There is a subtle interaction between deadlock detection and-finalizers (as created by 'Foreign.Concurrent.newForeignPtr' or the-functions in "System.Mem.Weak"): if a thread is blocked waiting for a-finalizer to run, then the thread will be considered deadlocked and-sent an exception.  So preferably don't do this, but if you have no-alternative then it is possible to prevent the thread from being-considered deadlocked by making a 'StablePtr' pointing to it.  Don't-forget to release the 'StablePtr' later with 'freeStablePtr'.--}
− Control/Concurrent.hs-boot 
@@ -1,30 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent--- Copyright   :  (c) The University of Glasgow 2018-2019--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (concurrency)------ A common interface to a collection of useful concurrency--- abstractions.----------------------------------------------------------------------------------module Control.Concurrent (-        -- * Bound Threads-        rtsSupportsBoundThreads,-        forkOS-    ) where--import Data.Bool--import GHC.IO-import GHC.Conc.Sync--rtsSupportsBoundThreads :: Bool-forkOS :: IO () -> IO ThreadId
− Control/Concurrent/Chan.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.Chan--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (concurrency)------ 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-  (-          -- * The 'Chan' type-        Chan,                   -- abstract--          -- * Operations-        newChan,-        writeChan,-        readChan,-        dupChan,--          -- * Stream interface-        getChanContents,-        writeList2Chan,-   ) where--import System.IO.Unsafe         ( unsafeInterleaveIO )-import Control.Concurrent.MVar-import Control.Exception (mask_)--#define _UPK_(x) {-# UNPACK #-} !(x)---- A channel is represented by two @MVar@s keeping track of the two ends--- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s--- are used to handle consumers trying to read from an empty channel.---- |'Chan' is an abstract type representing an unbounded FIFO channel.-data Chan a- = Chan _UPK_(MVar (Stream a))-        _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar-   deriving Eq -- ^ @since 4.4.0.0--type Stream a = MVar (ChItem a)--data ChItem a = ChItem a _UPK_(Stream a)-  -- benchmarks show that unboxing the MVar here is worthwhile, because-  -- although it leads to higher allocation, the channel data takes up-  -- less space and is therefore quicker to GC.---- See the Concurrent Haskell paper for a diagram explaining the--- how the different channel operations proceed.---- @newChan@ sets up the read and write end of a channel by initialising--- these two @MVar@s with an empty @MVar@.---- |Build and returns a new instance of 'Chan'.-newChan :: IO (Chan a)-newChan = do-   hole  <- newEmptyMVar-   readVar  <- newMVar hole-   writeVar <- newMVar hole-   return (Chan readVar writeVar)---- To put an element on a channel, a new hole at the write end is created.--- What was previously the empty @MVar@ at the back of the channel is then--- filled in with a new stream element holding the entered value and the--- new hole.---- |Write a value to a 'Chan'.-writeChan :: Chan a -> a -> IO ()-writeChan (Chan _ writeVar) val = do-  new_hole <- newEmptyMVar-  mask_ $ do-    old_hole <- takeMVar writeVar-    putMVar old_hole (ChItem val new_hole)-    putMVar writeVar new_hole---- The reason we don't simply do this:------    modifyMVar_ writeVar $ \old_hole -> do---      putMVar old_hole (ChItem val new_hole)---      return new_hole------ is because if an asynchronous exception is received after the 'putMVar'--- completes and before modifyMVar_ installs the new value, it will set the--- Chan's write end to a filled hole.---- |Read the next value from the 'Chan'. Blocks when the channel is empty. Since--- the read end of a channel is an 'MVar', this operation inherits fairness--- guarantees of 'MVar's (e.g. threads blocked in this operation are woken up in--- FIFO order).------ Throws 'Control.Exception.BlockedIndefinitelyOnMVar' when the channel is--- empty and no other thread holds a reference to the channel.-readChan :: Chan a -> IO a-readChan (Chan readVar _) =-  modifyMVar readVar $ \read_end -> do-    (ChItem val new_read_end) <- readMVar read_end-        -- Use readMVar here, not takeMVar,-        -- else dupChan doesn't work-    return (new_read_end, val)---- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to--- either channel from then on will be available from both.  Hence this creates--- a kind of broadcast channel, where data written by anyone is seen by--- everyone else.------ (Note that a duplicated channel is not equal to its original.--- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.)-dupChan :: Chan a -> IO (Chan a)-dupChan (Chan _ writeVar) = do-   hole       <- readMVar writeVar-   newReadVar <- newMVar hole-   return (Chan newReadVar writeVar)---- Operators for interfacing with functional streams.---- |Return a lazy list representing the contents of the supplied--- 'Chan', much like 'System.IO.hGetContents'.-getChanContents :: Chan a -> IO [a]-getChanContents ch-  = unsafeInterleaveIO (do-        x  <- readChan ch-        xs <- getChanContents ch-        return (x:xs)-    )---- |Write an entire list of items to a 'Chan'.-writeList2Chan :: Chan a -> [a] -> IO ()-writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
− Control/Concurrent/MVar.hs 
@@ -1,274 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, UnboxedTuples, MagicHash #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.MVar--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (concurrency)------ An @'MVar' t@ is mutable location that is either empty or contains a--- value of type @t@.  It has two fundamental operations: 'putMVar'--- which fills an 'MVar' if it is empty and blocks otherwise, and--- 'takeMVar' which empties an 'MVar' if it is full and blocks--- otherwise.  They can be used in multiple different ways:------   1. As synchronized mutable variables,------   2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and------   3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as---      wait and signal.------ They were introduced in the paper--- <https://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz "Concurrent Haskell">--- by Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne, though--- some details of their implementation have since then changed (in--- particular, a put on a full 'MVar' used to error, but now merely--- blocks.)------ === Applicability------ 'MVar's offer more flexibility than 'Data.IORef.IORef's, but less flexibility--- than 'GHC.Conc.STM'.  They are appropriate for building synchronization--- primitives and performing simple interthread communication; however--- they are very simple and susceptible to race conditions, deadlocks or--- uncaught exceptions.  Do not use them if you need perform larger--- atomic operations such as reading from multiple variables: use 'GHC.Conc.STM'--- instead.------ In particular, the "bigger" functions in this module ('swapMVar',--- 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply--- the composition of a 'takeMVar' followed by a 'putMVar' with--- exception safety.--- These only have atomicity guarantees if all other threads--- perform a 'takeMVar' before a 'putMVar' as well;  otherwise, they may--- block.------ === Fairness------ No thread can be blocked indefinitely on an 'MVar' unless another--- thread holds that 'MVar' indefinitely.  One usual implementation of--- this fairness guarantee is that threads blocked on an 'MVar' are--- served in a first-in-first-out fashion, but this is not guaranteed--- in the semantics.------ === Gotchas------ Like many other Haskell data structures, 'MVar's are lazy.  This--- means that if you place an expensive unevaluated thunk inside an--- 'MVar', it will be evaluated by the thread that consumes it, not the--- thread that produced it.  Be sure to 'evaluate' values to be placed--- in an 'MVar' to the appropriate normal form, or utilize a strict--- MVar provided by the strict-concurrency package.------ === Ordering------ 'MVar' operations are always observed to take place in the order--- they are written in the program, regardless of the memory model of--- the underlying machine.  This is in contrast to 'Data.IORef.IORef' operations--- which may appear out-of-order to another thread in some cases.------ === Example------ Consider the following concurrent data structure, a skip channel.--- This is a channel for an intermittent source of high bandwidth--- information (for example, mouse movement events.)  Writing to the--- channel never blocks, and reading from the channel only returns the--- most recent value, or blocks if there are no new values.  Multiple--- readers are supported with a @dupSkipChan@ operation.------ A skip channel is a pair of 'MVar's. The first 'MVar' contains the--- current value, and a list of semaphores that need to be notified--- when it changes. The second 'MVar' is a semaphore for this particular--- reader: it is full if there is a value in the channel that this--- reader has not read yet, and empty otherwise.------ @---     data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ())------     newSkipChan :: IO (SkipChan a)---     newSkipChan = do---         sem <- newEmptyMVar---         main <- newMVar (undefined, [sem])---         return (SkipChan main sem)------     putSkipChan :: SkipChan a -> a -> IO ()---     putSkipChan (SkipChan main _) v = do---         (_, sems) <- takeMVar main---         putMVar main (v, [])---         mapM_ (\sem -> putMVar sem ()) sems------     getSkipChan :: SkipChan a -> IO a---     getSkipChan (SkipChan main sem) = do---         takeMVar sem---         (v, sems) <- takeMVar main---         putMVar main (v, sem:sems)---         return v------     dupSkipChan :: SkipChan a -> IO (SkipChan a)---     dupSkipChan (SkipChan main _) = do---         sem <- newEmptyMVar---         (v, sems) <- takeMVar main---         putMVar main (v, sem:sems)---         return (SkipChan main sem)--- @------ This example was adapted from the original Concurrent Haskell paper.--- For more examples of 'MVar's being used to build higher-level--- synchronization primitives, see 'Control.Concurrent.Chan' and--- 'Control.Concurrent.QSem'.-----------------------------------------------------------------------------------module Control.Concurrent.MVar-        (-          -- * @MVar@s-          MVar-        , newEmptyMVar-        , newMVar-        , takeMVar-        , putMVar-        , readMVar-        , swapMVar-        , tryTakeMVar-        , tryPutMVar-        , isEmptyMVar-        , withMVar-        , withMVarMasked-        , modifyMVar_-        , modifyMVar-        , modifyMVarMasked_-        , modifyMVarMasked-        , tryReadMVar-        , mkWeakMVar-        , addMVarFinalizer-    ) where--import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,-                  tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar,-                  tryReadMVar-                )-import qualified GHC.MVar-import GHC.Weak-import GHC.Base--import Control.Exception.Base--{-|-  Take a value from an 'MVar', put a new value into the 'MVar' and-  return the value taken. This function is atomic only if there are-  no other producers for this 'MVar'.--}-swapMVar :: MVar a -> a -> IO a-swapMVar mvar new =-  mask_ $ do-    old <- takeMVar mvar-    putMVar mvar new-    return old--{-|-  'withMVar' is an exception-safe wrapper for operating on the contents-  of an 'MVar'.  This operation is exception-safe: it will replace the-  original contents of the 'MVar' if an exception is raised (see-  "Control.Exception").  However, it is only atomic if there are no-  other producers for this 'MVar'.--}-{-# INLINE withMVar #-}--- inlining has been reported to have dramatic effects; see--- http://www.haskell.org//pipermail/haskell/2006-May/017907.html-withMVar :: MVar a -> (a -> IO b) -> IO b-withMVar m io =-  mask $ \restore -> do-    a <- takeMVar m-    b <- restore (io a) `onException` putMVar m a-    putMVar m a-    return b--{-|-  Like 'withMVar', but the @IO@ action in the second argument is executed-  with asynchronous exceptions masked.--  @since 4.7.0.0--}-{-# INLINE withMVarMasked #-}-withMVarMasked :: MVar a -> (a -> IO b) -> IO b-withMVarMasked m io =-  mask_ $ do-    a <- takeMVar m-    b <- io a `onException` putMVar m a-    putMVar m a-    return b--{-|-  An exception-safe wrapper for modifying the contents of an 'MVar'.-  Like 'withMVar', 'modifyMVar' will replace the original contents of-  the 'MVar' if an exception is raised during the operation.  This-  function is only atomic if there are no other producers for this-  'MVar'.--}-{-# INLINE modifyMVar_ #-}-modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()-modifyMVar_ m io =-  mask $ \restore -> do-    a  <- takeMVar m-    a' <- restore (io a) `onException` putMVar m a-    putMVar m a'--{-|-  A slight variation on 'modifyMVar_' that allows a value to be-  returned (@b@) in addition to the modified value of the 'MVar'.--}-{-# INLINE modifyMVar #-}-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b-modifyMVar m io =-  mask $ \restore -> do-    a      <- takeMVar m-    (a',b) <- restore (io a >>= evaluate) `onException` putMVar m a-    putMVar m a'-    return b--{-|-  Like 'modifyMVar_', but the @IO@ action in the second argument is executed with-  asynchronous exceptions masked.--  @since 4.6.0.0--}-{-# INLINE modifyMVarMasked_ #-}-modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()-modifyMVarMasked_ m io =-  mask_ $ do-    a  <- takeMVar m-    a' <- io a `onException` putMVar m a-    putMVar m a'--{-|-  Like 'modifyMVar', but the @IO@ action in the second argument is executed with-  asynchronous exceptions masked.--  @since 4.6.0.0--}-{-# INLINE modifyMVarMasked #-}-modifyMVarMasked :: MVar a -> (a -> IO (a,b)) -> IO b-modifyMVarMasked m io =-  mask_ $ do-    a      <- takeMVar m-    (a',b) <- (io a >>= evaluate) `onException` putMVar m a-    putMVar m a'-    return b--{-# DEPRECATED addMVarFinalizer "use 'mkWeakMVar' instead" #-} -- deprecated in 7.6-addMVarFinalizer :: MVar a -> IO () -> IO ()-addMVarFinalizer = GHC.MVar.addMVarFinalizer---- | Make a 'Weak' pointer to an 'MVar', using the second argument as--- a finalizer to run when 'MVar' is garbage-collected------ @since 4.6.0.0-mkWeakMVar :: MVar a -> IO () -> IO (Weak (MVar a))-mkWeakMVar m@(MVar m#) (IO f) = IO $ \s ->-    case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)
− Control/Concurrent/QSem.hs 
@@ -1,129 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.QSem--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (concurrency)------ Simple quantity semaphores.-----------------------------------------------------------------------------------module Control.Concurrent.QSem-        ( -- * Simple Quantity Semaphores-          QSem,         -- abstract-          newQSem,      -- :: Int  -> IO QSem-          waitQSem,     -- :: QSem -> IO ()-          signalQSem    -- :: QSem -> IO ()-        ) where--import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar-                          , putMVar, newMVar, tryPutMVar)-import Control.Exception-import Data.Maybe---- | 'QSem' is a quantity semaphore in which the resource is acquired--- and released in units of one. It provides guaranteed FIFO ordering--- for satisfying blocked `waitQSem` calls.------ The pattern------ >   bracket_ waitQSem signalQSem (...)------ is safe; it never loses a unit of the resource.----newtype QSem = QSem (MVar (Int, [MVar ()], [MVar ()]))---- The semaphore state (i, xs, ys):------   i is the current resource value------   (xs,ys) is the queue of blocked threads, where the queue is---           given by xs ++ reverse ys.  We can enqueue new blocked threads---           by consing onto ys, and dequeue by removing from the head of xs.------ A blocked thread is represented by an empty (MVar ()).  To unblock--- the thread, we put () into the MVar.------ A thread can dequeue itself by also putting () into the MVar, which--- it must do if it receives an exception while blocked in waitQSem.--- This means that when unblocking a thread in signalQSem we must--- first check whether the MVar is already full; the MVar lock on the--- semaphore itself resolves race conditions between signalQSem and a--- thread attempting to dequeue itself.---- |Build a new 'QSem' with a supplied initial quantity.---  The initial quantity must be at least 0.-newQSem :: Int -> IO QSem-newQSem initial-  | initial < 0 = fail "newQSem: Initial quantity must be non-negative"-  | otherwise   = do-      sem <- newMVar (initial, [], [])-      return (QSem sem)---- |Wait for a unit to become available-waitQSem :: QSem -> IO ()-waitQSem (QSem m) =-  mask_ $ do-    (i,b1,b2) <- takeMVar m-    if i == 0-       then do-         b <- newEmptyMVar-         putMVar m (i, b1, b:b2)-         wait b-       else do-         let !z = i-1-         putMVar m (z, b1, b2)-         return ()-  where-    wait b = takeMVar b `onException`-                (uninterruptibleMask_ $ do -- Note [signal uninterruptible]-                   (i,b1,b2) <- takeMVar m-                   r <- tryTakeMVar b-                   r' <- if isJust r-                            then signal (i,b1,b2)-                            else do putMVar b (); return (i,b1,b2)-                   putMVar m r')---- |Signal that a unit of the 'QSem' is available-signalQSem :: QSem -> IO ()-signalQSem (QSem m) =-  uninterruptibleMask_ $ do -- Note [signal uninterruptible]-    r <- takeMVar m-    r' <- signal r-    putMVar m r'---- Note [signal uninterruptible]------   If we have------      bracket waitQSem signalQSem (...)------   and an exception arrives at the signalQSem, then we must not lose---   the resource.  The signalQSem is masked by bracket, but taking---   the MVar might block, and so it would be interruptible.  Hence we---   need an uninterruptibleMask here.------   This isn't ideal: during high contention, some threads won't be---   interruptible.  The QSemSTM implementation has better behaviour---   here, but it performs much worse than this one in some---   benchmarks.--signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()])-signal (i,a1,a2) =- if i == 0-   then loop a1 a2-   else let !z = i+1 in return (z, a1, a2)- where-   loop [] [] = return (1, [], [])-   loop [] b2 = loop (reverse b2) []-   loop (b:bs) b2 = do-     r <- tryPutMVar b ()-     if r then return (0, bs, b2)-          else loop bs b2
− Control/Concurrent/QSemN.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.QSemN--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (concurrency)------ Quantity semaphores in which each thread may wait for an arbitrary--- \"amount\".-----------------------------------------------------------------------------------module Control.Concurrent.QSemN-        (  -- * General Quantity Semaphores-          QSemN,        -- abstract-          newQSemN,     -- :: Int   -> IO QSemN-          waitQSemN,    -- :: QSemN -> Int -> IO ()-          signalQSemN   -- :: QSemN -> Int -> IO ()-      ) where--import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar-                          , tryPutMVar, isEmptyMVar)-import Control.Exception-import Control.Monad (when)-import Data.IORef (IORef, newIORef, atomicModifyIORef)-import System.IO.Unsafe (unsafePerformIO)---- | 'QSemN' is a quantity semaphore in which the resource is acquired--- and released in units of one. It provides guaranteed FIFO ordering--- for satisfying blocked `waitQSemN` calls.------ The pattern------ >   bracket_ (waitQSemN n) (signalQSemN n) (...)------ is safe; it never loses any of the resource.----data QSemN = QSemN !(IORef (Int, [(Int, MVar ())], [(Int, MVar ())]))---- The semaphore state (i, xs, ys):------   i is the current resource value------   (xs,ys) is the queue of blocked threads, where the queue is---           given by xs ++ reverse ys.  We can enqueue new blocked threads---           by consing onto ys, and dequeue by removing from the head of xs.------ A blocked thread is represented by an empty (MVar ()).  To unblock--- the thread, we put () into the MVar.------ A thread can dequeue itself by also putting () into the MVar, which--- it must do if it receives an exception while blocked in waitQSemN.--- This means that when unblocking a thread in signalQSemN we must--- first check whether the MVar is already full.---- |Build a new 'QSemN' with a supplied initial quantity.---  The initial quantity must be at least 0.-newQSemN :: Int -> IO QSemN-newQSemN initial-  | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"-  | otherwise   = do-      sem <- newIORef (initial, [], [])-      return (QSemN sem)---- An unboxed version of Maybe (MVar a)-data MaybeMV a = JustMV !(MVar a) | NothingMV---- |Wait for the specified quantity to become available-waitQSemN :: QSemN -> Int -> IO ()--- We need to mask here. Once we've enqueued our MVar, we need--- to be sure to wait for it. Otherwise, we could lose our--- allocated resource.-waitQSemN qs@(QSemN m) sz = mask_ $ do-    -- unsafePerformIO and not unsafeDupablePerformIO. We must-    -- be sure to wait on the same MVar that gets enqueued.-  mmvar <- atomicModifyIORef m $ \ (i,b1,b2) -> unsafePerformIO $ do-    let z = i-sz-    if z < 0-      then do-        b <- newEmptyMVar-        return ((i, b1, (sz,b):b2), JustMV b)-      else return ((z, b1, b2), NothingMV)--  -- Note: this case match actually allocates the MVar if necessary.-  case mmvar of-    NothingMV -> return ()-    JustMV b -> wait b-  where-    wait :: MVar () -> IO ()-    wait b =-      takeMVar b `onException` do-        already_filled <- not <$> tryPutMVar b ()-        when already_filled $ signalQSemN qs sz---- |Signal that a given quantity is now available from the 'QSemN'.-signalQSemN :: QSemN -> Int -> IO ()--- We don't need to mask here because we should *already* be masked--- here (e.g., by bracket). Indeed, if we're not already masked,--- it's too late to do so.------ What if the unsafePerformIO thunk is forced in another thread,--- and receives an asynchronous exception? That shouldn't be a--- problem: when we force it ourselves, presumably masked, we--- will resume its execution.-signalQSemN (QSemN m) sz0 = do-    -- unsafePerformIO and not unsafeDupablePerformIO. We must not-    -- wake up more threads than we're supposed to.-  unit <- atomicModifyIORef m $ \(i,a1,a2) ->-            unsafePerformIO (loop (sz0 + i) a1 a2)--  -- Forcing this will actually wake the necessary threads.-  evaluate unit- where-   loop 0  bs b2 = return ((0,  bs, b2), ())-   loop sz [] [] = return ((sz, [], []), ())-   loop sz [] b2 = loop sz (reverse b2) []-   loop sz ((j,b):bs) b2-     | j > sz = do-       r <- isEmptyMVar b-       if r then return ((sz, (j,b):bs, b2), ())-            else loop sz bs b2-     | otherwise = do-       r <- tryPutMVar b ()-       if r then loop (sz-j) bs b2-            else loop sz bs b2
− Control/Exception.hs 
@@ -1,398 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Exception--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (extended exceptions)------ This module provides support for raising and catching both built-in--- and user-defined exceptions.------ In addition to exceptions thrown by 'IO' operations, exceptions may--- be thrown by pure code (imprecise exceptions) or by external events--- (asynchronous exceptions), but may only be caught in the 'IO' monad.--- For more details, see:------  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,---    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,---    in /PLDI'99/.------  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton---    Jones, Andy Moran and John Reppy, in /PLDI'01/.------  * /An Extensible Dynamically-Typed Hierarchy of Exceptions/,---    by Simon Marlow, in /Haskell '06/.-----------------------------------------------------------------------------------module Control.Exception (--        -- * The Exception type-        SomeException(..),-        Exception(..),          -- class-        IOException,            -- instance Eq, Ord, Show, Typeable, Exception-        ArithException(..),     -- instance Eq, Ord, Show, Typeable, Exception-        ArrayException(..),     -- instance Eq, Ord, Show, Typeable, Exception-        AssertionFailed(..),-        SomeAsyncException(..),-        AsyncException(..),     -- instance Eq, Ord, Show, Typeable, Exception-        asyncExceptionToException, asyncExceptionFromException,--        NonTermination(..),-        NestedAtomically(..),-        BlockedIndefinitelyOnMVar(..),-        BlockedIndefinitelyOnSTM(..),-        AllocationLimitExceeded(..),-        CompactionFailed(..),-        Deadlock(..),-        NoMethodError(..),-        PatternMatchFail(..),-        RecConError(..),-        RecSelError(..),-        RecUpdError(..),-        ErrorCall(..),-        TypeError(..),--        -- * Throwing exceptions-        throw,-        throwIO,-        ioError,-        throwTo,--        -- * Catching Exceptions--        -- $catching--        -- ** Catching all exceptions--        -- $catchall--        -- ** The @catch@ functions-        catch,-        catches, Handler(..),-        catchJust,--        -- ** The @handle@ functions-        handle,-        handleJust,--        -- ** The @try@ functions-        try,-        tryJust,--        -- ** The @evaluate@ function-        evaluate,--        -- ** The @mapException@ function-        mapException,--        -- * Asynchronous Exceptions--        -- $async--        -- ** Asynchronous exception control--        -- |The following functions allow a thread to control delivery of-        -- asynchronous exceptions during a critical region.--        mask,-        mask_,-        uninterruptibleMask,-        uninterruptibleMask_,-        MaskingState(..),-        getMaskingState,-        interruptible,-        allowInterrupt,--        -- *** Applying @mask@ to an exception handler--        -- $block_handler--        -- *** Interruptible operations--        -- $interruptible--        -- * Assertions--        assert,--        -- * Utilities--        bracket,-        bracket_,-        bracketOnError,--        finally,-        onException,--  ) where--import Control.Exception.Base--import GHC.Base-import GHC.IO (interruptible)---- | You need this when using 'catches'.-data Handler a = forall e . Exception e => Handler (e -> IO a)---- | @since 4.6.0.0-instance Functor Handler where-     fmap f (Handler h) = Handler (fmap f . h)--{- |-Sometimes you want to catch two different sorts of exception. You could-do something like--> f = expr `catch` \ (ex :: ArithException) -> handleArith ex->          `catch` \ (ex :: IOException)    -> handleIO    ex--However, there are a couple of problems with this approach. The first is-that having two exception handlers is inefficient. However, the more-serious issue is that the second exception handler will catch exceptions-in the first, e.g. in the example above, if @handleArith@ throws an-@IOException@ then the second exception handler will catch it.--Instead, we provide a function 'catches', which would be used thus:--> f = expr `catches` [Handler (\ (ex :: ArithException) -> handleArith ex),->                     Handler (\ (ex :: IOException)    -> handleIO    ex)]--}-catches :: IO a -> [Handler a] -> IO a-catches io handlers = io `catch` catchesHandler handlers--catchesHandler :: [Handler a] -> SomeException -> IO a-catchesHandler handlers e = foldr tryHandler (throw e) handlers-    where tryHandler (Handler handler) res-              = case fromException e of-                Just e' -> handler e'-                Nothing -> res---- -------------------------------------------------------------------------------- Catching exceptions--{- $catching--There are several functions for catching and examining-exceptions; all of them may only be used from within the-'IO' monad.--Here's a rule of thumb for deciding which catch-style function to-use:-- * If you want to do some cleanup in the event that an exception-   is raised, use 'finally', 'bracket' or 'onException'.-- * To recover after an exception and do something else, the best-   choice is to use one of the 'try' family.-- * ... unless you are recovering from an asynchronous exception, in which-   case use 'catch' or 'catchJust'.--The difference between using 'try' and 'catch' for recovery is that in-'catch' the handler is inside an implicit 'mask' (see \"Asynchronous-Exceptions\") which is important when catching asynchronous-exceptions, but when catching other kinds of exception it is-unnecessary.  Furthermore it is possible to accidentally stay inside-the implicit 'mask' by tail-calling rather than returning from the-handler, which is why we recommend using 'try' rather than 'catch' for-ordinary exception recovery.--A typical use of 'tryJust' for recovery looks like this:-->  do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME"->     case r of->       Left  e    -> ...->       Right home -> ...---}---- -------------------------------------------------------------------------------- Asynchronous exceptions---- | 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.------ When called outside 'mask', or inside 'uninterruptibleMask', this--- function has no effect.------ @since 4.4.0.0-allowInterrupt :: IO ()-allowInterrupt = interruptible $ return ()--{- $async-- #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to-external influences, and can be raised at any point during execution.-'StackOverflow' and 'HeapOverflow' are two examples of-system-generated asynchronous exceptions.--The primary source of asynchronous exceptions, however, is-'throwTo':-->  throwTo :: ThreadId -> Exception -> IO ()--'throwTo' (also 'Control.Concurrent.killThread') allows one-running thread to raise an arbitrary exception in another thread.  The-exception is therefore asynchronous with respect to the target thread,-which could be doing anything at the time it receives the exception.-Great care should be taken with asynchronous exceptions; it is all too-easy to introduce race conditions by the over zealous use of-'throwTo'.--}--{- $block_handler-There\'s an implied 'mask' around every exception handler in a call-to one of the 'catch' family of functions.  This is because that is-what you want most of the time - it eliminates a common race condition-in starting an exception handler, because there may be no exception-handler on the stack to handle another exception if one arrives-immediately.  If asynchronous exceptions are masked on entering the-handler, though, we have time to install a new exception handler-before being interrupted.  If this weren\'t the default, one would have-to write something like-->      mask $ \restore ->->           catch (restore (...))->                 (\e -> handler)--If you need to unmask asynchronous exceptions again in the exception-handler, @restore@ can be used there too.--Note that 'try' and friends /do not/ have a similar default, because-there is no exception handler in this case.  Don't use 'try' for-recovering from an asynchronous exception.--}--{- $interruptible-- #interruptible#-Some operations are /interruptible/, which means that they can receive-asynchronous exceptions even in the scope of a 'mask'.  Any function-which may itself block is defined as interruptible; this includes-'Control.Concurrent.MVar.takeMVar'-(but not 'Control.Concurrent.MVar.tryTakeMVar'),-and most operations which perform-some I\/O with the outside world.  The reason for having-interruptible operations is so that we can write things like-->      mask $ \restore -> do->         a <- takeMVar m->         catch (restore (...))->               (\e -> ...)--if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,-then this particular-combination could lead to deadlock, because the thread itself would be-blocked in a state where it can\'t receive any asynchronous exceptions.-With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be-safe in the knowledge that the thread can receive exceptions right up-until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.-Similar arguments apply for other interruptible operations like-'System.IO.openFile'.--It is useful to think of 'mask' not as a way to completely prevent-asynchronous exceptions, but as a way to switch from asynchronous mode-to polling mode.  The main difficulty with asynchronous-exceptions is that they normally can occur anywhere, but within a-'mask' an asynchronous exception is only raised by operations that are-interruptible (or call other interruptible operations).  In many cases-these operations may themselves raise exceptions, such as I\/O errors,-so the caller will usually be prepared to handle exceptions arising from the-operation anyway.  To perform an explicit poll for asynchronous exceptions-inside 'mask', use 'allowInterrupt'.--Sometimes it is too onerous to handle exceptions in the middle of a-critical piece of stateful code.  There are three ways to handle this-kind of situation:-- * Use STM.  Since a transaction is always either completely executed-   or not at all, transactions are a good way to maintain invariants-   over state in the presence of asynchronous (and indeed synchronous)-   exceptions.-- * Use 'mask', and avoid interruptible operations.  In order to do-   this, we have to know which operations are interruptible.  It is-   impossible to know for any given library function whether it might-   invoke an interruptible operation internally; so instead we give a-   list of guaranteed-not-to-be-interruptible operations below.-- * Use 'uninterruptibleMask'.  This is generally not recommended,-   unless you can guarantee that any interruptible operations invoked-   during the scope of 'uninterruptibleMask' can only ever block for-   a short time.  Otherwise, 'uninterruptibleMask' is a good way to-   make your program deadlock and be unresponsive to user interrupts.--The following operations are guaranteed not to be interruptible:-- * operations on 'Data.IORef.IORef' from "Data.IORef"-- * STM transactions that do not use 'GHC.Conc.retry'-- * everything from the @Foreign@ modules-- * everything from "Control.Exception" except for 'throwTo'-- * 'Control.Concurrent.MVar.tryTakeMVar', 'Control.Concurrent.MVar.tryPutMVar',-   'Control.Concurrent.MVar.isEmptyMVar'-- * 'Control.Concurrent.MVar.takeMVar' if the 'Control.Concurrent.MVar.MVar' is-   definitely full, and conversely 'Control.Concurrent.MVar.putMVar' if the-   'Control.Concurrent.MVar.MVar' is definitely empty-- * 'Control.Concurrent.MVar.newEmptyMVar', 'Control.Concurrent.MVar.newMVar'-- * 'Control.Concurrent.forkIO', 'Control.Concurrent.myThreadId'---}--{- $catchall--It is possible to catch all exceptions, by using the type 'SomeException':--> catch f (\e -> ... (e :: SomeException) ...)--HOWEVER, this is normally not what you want to do!--For example, suppose you want to read a file, but if it doesn't exist-then continue as if it contained \"\".  You might be tempted to just-catch all exceptions and return \"\" in the handler. However, this has-all sorts of undesirable consequences.  For example, if the user-presses control-C at just the right moment then the 'UserInterrupt'-exception will be caught, and the program will continue running under-the belief that the file contains \"\".  Similarly, if another thread-tries to kill the thread reading the file then the 'ThreadKilled'-exception will be ignored.--Instead, you should only catch exactly the exceptions that you really-want. In this case, this would likely be more specific than even-\"any IO exception\"; a permissions error would likely also want to be-handled differently. Instead, you would probably want something like:--> e <- tryJust (guard . isDoesNotExistError) (readFile f)-> let str = either (const "") id e--There are occasions when you really do need to catch any sort of-exception. However, in most cases this is just so you can do some-cleaning up; you aren't actually interested in the exception itself.-For example, if you open a file then you want to close it again,-whether processing the file executes normally or throws an exception.-However, in these cases you can use functions like 'bracket', 'finally'-and 'onException', which never actually pass you the exception, but-just call the cleanup functions at the appropriate points.--But sometimes you really do need to catch any exception, and actually-see what the exception is. One example is at the very top-level of a-program, you may wish to catch any exception, print it to a logfile or-the screen, and then exit gracefully. For these cases, you can use-'catch' (or one of the other exception-catching functions) with the-'SomeException' type.--}-
− Control/Exception/Base.hs 
@@ -1,416 +0,0 @@-{-# LANGUAGE MagicHash         #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy       #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Exception.Base--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (extended exceptions)------ Extensible exceptions, except for multiple handlers.-----------------------------------------------------------------------------------module Control.Exception.Base (--        -- * The Exception type-        SomeException(..),-        Exception(..),-        IOException,-        ArithException(..),-        ArrayException(..),-        AssertionFailed(..),-        SomeAsyncException(..), AsyncException(..),-        asyncExceptionToException, asyncExceptionFromException,-        NonTermination(..),-        NestedAtomically(..),-        BlockedIndefinitelyOnMVar(..),-        FixIOException (..),-        BlockedIndefinitelyOnSTM(..),-        AllocationLimitExceeded(..),-        CompactionFailed(..),-        Deadlock(..),-        NoMethodError(..),-        PatternMatchFail(..),-        RecConError(..),-        RecSelError(..),-        RecUpdError(..),-        ErrorCall(..),-        TypeError(..), -- #10284, custom error type for deferred type errors--        -- * Throwing exceptions-        throwIO,-        throw,-        ioError,-        throwTo,--        -- * Catching Exceptions--        -- ** The @catch@ functions-        catch,-        catchJust,--        -- ** The @handle@ functions-        handle,-        handleJust,--        -- ** The @try@ functions-        try,-        tryJust,-        onException,--        -- ** The @evaluate@ function-        evaluate,--        -- ** The @mapException@ function-        mapException,--        -- * Asynchronous Exceptions--        -- ** Asynchronous exception control-        mask,-        mask_,-        uninterruptibleMask,-        uninterruptibleMask_,-        MaskingState(..),-        getMaskingState,--        -- * Assertions--        assert,--        -- * Utilities--        bracket,-        bracket_,-        bracketOnError,--        finally,--        -- * Calls for GHC runtime-        recSelError, recConError, runtimeError,-        nonExhaustiveGuardsError, patError, noMethodBindingError,-        typeError,-        nonTermination, nestedAtomically,-  ) where--import           GHC.Base-import           GHC.Exception-import           GHC.IO           hiding (bracket, finally, onException)-import           GHC.IO.Exception-import           GHC.Show--- import GHC.Exception hiding ( Exception )-import           GHC.Conc.Sync--import           Data.Either---------------------------------------------------------------------------------- Catching exceptions---- | The function 'catchJust' is like 'catch', but it takes an extra--- argument which is an /exception predicate/, a function which--- selects which type of exceptions we\'re interested in.------ > catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing)--- >           (readFile f)--- >           (\_ -> do hPutStrLn stderr ("No such file: " ++ show f)--- >                     return "")------ Any other exceptions which are not matched by the predicate--- are re-raised, and may be caught by an enclosing--- 'catch', 'catchJust', etc.-catchJust-        :: Exception e-        => (e -> Maybe b)         -- ^ Predicate to select exceptions-        -> IO a                   -- ^ Computation to run-        -> (b -> IO a)            -- ^ Handler-        -> IO a-catchJust p a handler = catch a handler'-  where handler' e = case p e of-                        Nothing -> throwIO e-                        Just b  -> handler b---- | A version of 'catch' with the arguments swapped around; useful in--- situations where the code for the handler is shorter.  For example:------ >   do handle (\NonTermination -> exitWith (ExitFailure 1)) $--- >      ...-handle     :: Exception e => (e -> IO a) -> IO a -> IO a-handle     =  flip catch---- | A version of 'catchJust' with the arguments swapped around (see--- 'handle').-handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a-handleJust p =  flip (catchJust p)---------------------------------------------------------------------------------- 'mapException'---- | This function maps one exception into another as proposed in the--- paper \"A semantics for imprecise exceptions\".---- Notice that the usage of 'unsafePerformIO' is safe here.--mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a-mapException f v = unsafePerformIO (catch (evaluate v)-                                          (\x -> throwIO (f x)))---------------------------------------------------------------------------------- 'try' and variations.---- | Similar to 'catch', but returns an 'Either' result which is--- @('Right' a)@ if no exception of type @e@ was raised, or @('Left' ex)@--- if an exception of type @e@ was raised and its value is @ex@.--- If any other type of exception is raised then it will be propagated--- up to the next enclosing exception handler.------ >  try a = catch (Right `liftM` a) (return . Left)--try :: Exception e => IO a -> IO (Either e a)-try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))---- | A variant of 'try' that takes an exception predicate to select--- which exceptions are caught (c.f. 'catchJust').  If the exception--- does not match the predicate, it is re-thrown.-tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)-tryJust p a = do-  r <- try a-  case r of-        Right v -> return (Right v)-        Left  e -> case p e of-                        Nothing -> throwIO e-                        Just b  -> return (Left b)---- | Like 'finally', but only performs the final action if there was an--- exception raised by the computation.-onException :: IO a -> IO b -> IO a-onException io what = io `catch` \e -> do _ <- what-                                          throwIO (e :: SomeException)---------------------------------------------------------------------------------- Some Useful Functions---- | When you want to acquire a resource, do some work with it, and--- then release the resource, it is a good idea to use 'bracket',--- because 'bracket' will install the necessary exception handler to--- release the resource in the event that an exception is raised--- during the computation.  If an exception is raised, then 'bracket' will--- re-raise the exception (after performing the release).------ A common example is opening a file:------ > bracket--- >   (openFile "filename" ReadMode)--- >   (hClose)--- >   (\fileHandle -> do { ... })------ The arguments to 'bracket' are in this order so that we can partially apply--- it, e.g.:------ > withFile name mode = bracket (openFile name mode) hClose------ Bracket wraps the release action with 'mask', which is sufficient to ensure--- that the release action executes to completion when it does not invoke any--- interruptible actions, even in the presence of asynchronous exceptions.  For--- example, `hClose` is uninterruptible when it is not racing other uses of the--- handle.  Similarly, closing a socket (from \"network\" package) is also--- uninterruptible under similar conditions.  An example of an interruptible--- action is 'killThread'.  Completion of interruptible release actions can be--- ensured by wrapping them in in 'uninterruptibleMask_', but this risks making--- the program non-responsive to @Control-C@, or timeouts.  Another option is to--- run the release action asynchronously in its own thread:------ > void $ uninterruptibleMask_ $ forkIO $ do { ... }------ The resource will be released as soon as possible, but the thread that invoked--- bracket will not block in an uninterruptible state.----bracket-        :: IO a         -- ^ computation to run first (\"acquire resource\")-        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")-        -> (a -> IO c)  -- ^ computation to run in-between-        -> IO c         -- returns the value from the in-between computation-bracket before after thing =-  mask $ \restore -> do-    a <- before-    r <- restore (thing a) `onException` after a-    _ <- after a-    return r---- | A specialised variant of 'bracket' with just a computation to run--- afterward.----finally :: IO a         -- ^ computation to run first-        -> IO b         -- ^ computation to run afterward (even if an exception-                        -- was raised)-        -> IO a         -- returns the value from the first computation-a `finally` sequel =-  mask $ \restore -> do-    r <- restore a `onException` sequel-    _ <- sequel-    return r---- | A variant of 'bracket' where the return value from the first computation--- is not required.-bracket_ :: IO a -> IO b -> IO c -> IO c-bracket_ before after thing = bracket before (const after) (const thing)---- | Like 'bracket', but only performs the final action if there was an--- exception raised by the in-between computation.-bracketOnError-        :: IO a         -- ^ computation to run first (\"acquire resource\")-        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")-        -> (a -> IO c)  -- ^ computation to run in-between-        -> IO c         -- returns the value from the in-between computation-bracketOnError before after thing =-  mask $ \restore -> do-    a <- before-    restore (thing a) `onException` after a----------- |A pattern match failed. The @String@ gives information about the--- source location of the pattern.-newtype PatternMatchFail = PatternMatchFail String---- | @since 4.0-instance Show PatternMatchFail where-    showsPrec _ (PatternMatchFail err) = showString err---- | @since 4.0-instance Exception PatternMatchFail----------- |A record selector was applied to a constructor without the--- appropriate field. This can only happen with a datatype with--- multiple constructors, where some fields are in one constructor--- but not another. The @String@ gives information about the source--- location of the record selector.-newtype RecSelError = RecSelError String---- | @since 4.0-instance Show RecSelError where-    showsPrec _ (RecSelError err) = showString err---- | @since 4.0-instance Exception RecSelError----------- |An uninitialised record field was used. The @String@ gives--- information about the source location where the record was--- constructed.-newtype RecConError = RecConError String---- | @since 4.0-instance Show RecConError where-    showsPrec _ (RecConError err) = showString err---- | @since 4.0-instance Exception RecConError----------- |A record update was performed on a constructor without the--- appropriate field. This can only happen with a datatype with--- multiple constructors, where some fields are in one constructor--- but not another. The @String@ gives information about the source--- location of the record update.-newtype RecUpdError = RecUpdError String---- | @since 4.0-instance Show RecUpdError where-    showsPrec _ (RecUpdError err) = showString err---- | @since 4.0-instance Exception RecUpdError----------- |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.-newtype NoMethodError = NoMethodError String---- | @since 4.0-instance Show NoMethodError where-    showsPrec _ (NoMethodError err) = showString err---- | @since 4.0-instance Exception NoMethodError----------- |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---- | @since 4.9.0.0-instance Show TypeError where-    showsPrec _ (TypeError err) = showString err---- | @since 4.9.0.0-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---- | @since 4.0-instance Show NonTermination where-    showsPrec _ NonTermination = showString "<<loop>>"---- | @since 4.0-instance Exception NonTermination----------- |Thrown when the program attempts to call @atomically@, from the @stm@--- package, inside another call to @atomically@.-data NestedAtomically = NestedAtomically---- | @since 4.0-instance Show NestedAtomically where-    showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"---- | @since 4.0-instance Exception NestedAtomically----------- See Note [Compiler error functions] in ghc-prim:GHC.Prim.Panic-recSelError, recConError, runtimeError,-  nonExhaustiveGuardsError, patError, noMethodBindingError,-  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 = errorWithoutStackTrace (unpackCStringUtf8# s)                   -- No location info unfortunately--nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))-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-nonTermination = toException NonTermination---- GHC's RTS calls this-nestedAtomically :: SomeException-nestedAtomically = toException NestedAtomically
− Control/Monad.hs 
@@ -1,394 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'Functor', 'Monad' and 'MonadPlus' classes,--- with some useful operations on monads.--module Control.Monad-    (-    -- * Functor and monad classes--      Functor(..)-    , Monad((>>=), (>>), return)-    , MonadFail(fail)-    , MonadPlus(mzero, mplus)-    -- * Functions--    -- ** Naming conventions-    -- $naming--    -- ** Basic @Monad@ functions--    , mapM-    , mapM_-    , forM-    , forM_-    , sequence-    , sequence_-    , (=<<)-    , (>=>)-    , (<=<)-    , forever-    , void--    -- ** Generalisations of list functions--    , join-    , msum-    , mfilter-    , filterM-    , mapAndUnzipM-    , zipWithM-    , zipWithM_-    , foldM-    , foldM_-    , replicateM-    , replicateM_--    -- ** Conditional execution of monadic expressions--    , guard-    , when-    , unless--    -- ** Monadic lifting operators--    , liftM-    , liftM2-    , liftM3-    , liftM4-    , liftM5--    , ap--    -- ** Strict monadic functions--    , (<$!>)-    ) where--import Control.Monad.Fail ( MonadFail(fail) )-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 )-import GHC.Num  ( (-) )---- $setup--- >>> import Prelude--- >>> let safeDiv x y = guard (y /= 0) >> Just (x `div` y :: Int)---- -------------------------------------------------------------------------------- Functions mandated by the Prelude---- | Conditional failure of 'Alternative' computations. Defined by------ @--- guard True  = 'pure' ()--- guard False = 'empty'--- @------ ==== __Examples__------ Common uses of 'guard' include conditionally signaling an error in--- an error monad and conditionally rejecting the current choice in an--- 'Alternative'-based parser.------ As an example of signaling an error in the error monad 'Maybe',--- consider a safe division function @safeDiv x y@ that returns--- 'Nothing' when the denominator @y@ is zero and @'Just' (x \`div\`--- y)@ otherwise. For example:------ >>> safeDiv 4 0--- Nothing------ >>> safeDiv 4 2--- Just 2------ A definition of @safeDiv@ using guards, but not 'guard':------ @--- safeDiv :: Int -> Int -> Maybe Int--- safeDiv x y | y /= 0    = Just (x \`div\` y)---             | otherwise = Nothing--- @------ A definition of @safeDiv@ using 'guard' and 'Monad' @do@-notation:------ @--- safeDiv :: Int -> Int -> Maybe Int--- safeDiv x y = do---   guard (y /= 0)---   return (x \`div\` y)--- @-guard           :: (Alternative f) => Bool -> f ()-guard True      =  pure ()-guard False     =  empty---- | This generalizes the list-based 'Data.List.filter' function.--{-# INLINE filterM #-}-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 <=<, >=>---- | Left-to-right composition of Kleisli arrows.------ \'@(bs '>=>' cs) a@\' can be understood as the @do@ expression------ @--- do b <- bs a---    cs b--- @-(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)-f >=> g     = \x -> f x >>= g---- | Right-to-left composition of Kleisli arrows. @('>=>')@, 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 (>=>)---- | Repeat an action indefinitely.------ ==== __Examples__------ A common use of 'forever' is to process input from network sockets,--- 'System.IO.Handle's, and channels--- (e.g. 'Control.Concurrent.MVar.MVar' and--- 'Control.Concurrent.Chan.Chan').------ For example, here is how we might implement an [echo--- server](https://en.wikipedia.org/wiki/Echo_Protocol), using--- 'forever' both to listen for client connections on a network socket--- and to echo client input on client connection handles:------ @--- echoServer :: Socket -> IO ()--- echoServer socket = 'forever' $ do---   client <- accept socket---   'Control.Concurrent.forkFinally' (echo client) (\\_ -> hClose client)---   where---     echo :: Handle -> IO ()---     echo client = 'forever' $---       hGetLine client >>= hPutStrLn client--- @------ Note that "forever" isn't necessarily non-terminating.--- If the action is in a @'MonadPlus'@ and short-circuits after some number of iterations.--- then @'forever'@ actually returns `mzero`, effectively short-circuiting its caller.-forever     :: (Applicative f) => f a -> f b-{-# INLINE forever #-}-forever a   = let a' = a *> a' in a'--- Use explicit sharing here, as it prevents a space leak regardless of--- optimizations.---- -------------------------------------------------------------------------------- Other monad functions---- | 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 monad.-mapAndUnzipM      :: (Applicative m) => (a -> m (b,c)) -> [a] -> m ([b], [c])-{-# INLINE mapAndUnzipM #-}--- Inline so that fusion with 'unzip' and 'traverse' has a chance to fire.--- See Note [Inline @unzipN@ functions] in GHC/OldList.hs.-mapAndUnzipM f xs =  unzip <$> traverse f xs---- | The 'zipWithM' function generalizes 'zipWith' to arbitrary applicative functors.-zipWithM          :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m [c]-{-# INLINE zipWithM #-}--- Inline so that fusion with zipWith and sequenceA have a chance to fire--- See Note [Fusion for zipN/zipWithN] in List.hs]-zipWithM f xs ys  =  sequenceA (zipWith f xs ys)---- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.-zipWithM_         :: (Applicative m) => (a -> b -> m c) -> [a] -> [b] -> m ()-{-# INLINE zipWithM_ #-}--- Inline so that fusion with zipWith and sequenceA have a chance to fire--- See Note [Fusion for zipN/zipWithN] in List.hs]-zipWithM_ f xs ys =  sequenceA_ (zipWith f xs ys)--{- | The 'foldM' function is analogous to 'Data.Foldable.foldl', except that its result is-encapsulated in a monad. Note that 'foldM' works from left-to-right over-the list arguments. This could be an issue where @('>>')@ and the `folded-function' are not commutative.---> foldM f a1 [x1, x2, ..., xm]->-> ==->-> do->   a2 <- f a1 x1->   a3 <- f a2 x2->   ...->   f am xm--If right-to-left evaluation is required, the input list should be reversed.--Note: 'foldM' is the same as 'foldlM'--}--foldM          :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b-{-# INLINABLE foldM #-}-{-# SPECIALISE foldM :: (a -> b -> IO a) -> a -> [b] -> IO a #-}-{-# SPECIALISE foldM :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a #-}-foldM          = foldlM---- | Like 'foldM', but discards the result.-foldM_         :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m ()-{-# INLINABLE foldM_ #-}-{-# SPECIALISE foldM_ :: (a -> b -> IO a) -> a -> [b] -> IO () #-}-{-# 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-recursive 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 happens for foldr, for example) thereby-specialising for the particular action.--For further information, see this issue comment, which includes side-by-side-Core: https://gitlab.haskell.org/ghc/ghc/issues/11795#note_118976--}---- | @'replicateM' n act@ performs the action @act@ @n@ times,--- and then returns the list of results:------ ==== __Examples__------ >>> import Control.Monad.State--- >>> runState (replicateM 3 $ state $ \s -> (s, s + 1)) 1--- ([1,2,3],4)----replicateM        :: (Applicative m) => Int -> m a -> m [a]-{-# INLINABLE replicateM #-}-{-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-}-{-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-}-replicateM cnt0 f =-    loop cnt0-  where-    loop cnt-        | cnt <= 0  = pure []-        | otherwise = liftA2 (:) f (loop (cnt - 1))---- | Like 'replicateM', but discards the result.------ ==== __Examples__------ >>> replicateM_ 3 (putStrLn "a")--- a--- a--- a----replicateM_       :: (Applicative m) => Int -> m a -> m ()-{-# INLINABLE replicateM_ #-}-{-# SPECIALISE replicateM_ :: Int -> IO a -> IO () #-}-{-# SPECIALISE replicateM_ :: Int -> Maybe a -> Maybe () #-}-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 ()-{-# INLINABLE unless #-}-{-# SPECIALISE unless :: Bool -> IO () -> IO () #-}-{-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-}-unless p s        =  if p then pure () else s--infixl 4 <$!>---- | Strict version of 'Data.Functor.<$>'.------ @since 4.8.0.0-(<$!>) :: Monad m => (a -> b) -> m a -> m b-{-# INLINE (<$!>) #-}-f <$!> m = do-  x <- m-  let z = f x-  z `seq` return z----- -------------------------------------------------------------------------------- Other MonadPlus functions---- | Direct 'MonadPlus' equivalent of 'Data.List.filter'.------ ==== __Examples__------ The 'Data.List.filter' function is just 'mfilter' specialized to--- the list monad:------ @--- 'Data.List.filter' = ( 'mfilter' :: (a -> Bool) -> [a] -> [a] )--- @------ An example using 'mfilter' with the 'Maybe' monad:------ >>> mfilter odd (Just 1)--- Just 1--- >>> mfilter odd (Just 2)--- Nothing----mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a-{-# INLINABLE mfilter #-}-mfilter p ma = do-  a <- ma-  if p a then return a else mzero--{- $naming--The functions in this library use the following naming conventions:--* A postfix \'@M@\' always stands for a function in the Kleisli category:-  The monad type constructor @m@ is added to function results-  (modulo currying) and nowhere else.  So, for example,--> filter  ::              (a ->   Bool) -> [a] ->   [a]-> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]--* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.-  Thus, for example:--> sequence  :: Monad m => [m a] -> m [a]-> sequence_ :: Monad m => [m a] -> m ()--* A prefix \'@m@\' generalizes an existing function to a monadic form.-  Thus, for example:--> filter  ::                (a -> Bool) -> [a] -> [a]-> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a---}
− Control/Monad/Fail.hs 
@@ -1,80 +0,0 @@-{-# 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 <https://prime.haskell.org/wiki/Libraries/Proposals/MonadFail>--- for more details.------ @since 4.9.0.0----module Control.Monad.Fail ( MonadFail(fail) ) where--import GHC.Base (String, Monad(), Maybe(Nothing), 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 'Control.Monad.>>=',------ @--- fail s >>= f  =  fail s--- @------ If your 'Monad' is also 'Control.Monad.MonadPlus', a popular definition is------ @--- fail _ = mzero--- @------ @since 4.9.0.0-class Monad m => MonadFail m where-    fail :: String -> m a----- | @since 4.9.0.0-instance MonadFail Maybe where-    fail _ = Nothing---- | @since 4.9.0.0-instance MonadFail [] where-    {-# INLINE fail #-}-    fail _ = []---- | @since 4.9.0.0-instance MonadFail IO where-    fail = failIO
− Control/Monad/Fix.hs 
@@ -1,164 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Fix--- Copyright   :  (c) Andy Gill 2001,---                (c) Oregon Graduate Institute of Science and Technology, 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)--- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Monadic fixpoints.------ For a detailed discussion, see Levent Erkok's thesis,--- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.-----------------------------------------------------------------------------------module Control.Monad.Fix (-        MonadFix(mfix),-        fix-  ) where--import Data.Either-import Data.Function ( fix )-import Data.Maybe-import Data.Monoid ( Dual(..), Sum(..), Product(..)-                   , First(..), Last(..), Alt(..), Ap(..) )-import Data.Ord ( Down(..) )-import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) )-import GHC.Generics-import GHC.List ( head, tail )-import GHC.Tuple (Solo (..))-import Control.Monad.ST.Imp-import System.IO---- | Monads having fixed points with a \'knot-tying\' semantics.--- Instances of 'MonadFix' should satisfy the following laws:------ [Purity]---      @'mfix' ('Control.Monad.return' . h)  =  'Control.Monad.return' ('fix' h)@------ [Left shrinking (or Tightening)]---      @'mfix' (\\x -> a >>= \\y -> f x y)  =  a >>= \\y -> 'mfix' (\\x -> f x y)@------ [Sliding]---      @'mfix' ('Control.Monad.liftM' h . f)  =  'Control.Monad.liftM' h ('mfix' (f . h))@,---      for strict @h@.------ [Nesting]---      @'mfix' (\\x -> 'mfix' (\\y -> f x y))  =  'mfix' (\\x -> f x x)@------ This class is used in the translation of the recursive @do@ notation--- supported by GHC and Hugs.-class (Monad m) => MonadFix m where-        -- | The fixed point of a monadic computation.-        -- @'mfix' f@ executes the action @f@ only once, with the eventual-        -- output fed back as the input.  Hence @f@ should not be strict,-        -- for then @'mfix' f@ would diverge.-        mfix :: (a -> m a) -> m a---- Instances of MonadFix for Prelude monads---- | @since 4.15-instance MonadFix Solo where-    mfix f = let a = f (unSolo a) in a-             where unSolo (Solo x) = x---- | @since 2.01-instance MonadFix Maybe where-    mfix f = let a = f (unJust a) in a-             where unJust (Just x) = x-                   unJust Nothing  = errorWithoutStackTrace "mfix Maybe: Nothing"---- | @since 2.01-instance MonadFix [] where-    mfix f = case fix (f . head) of-               []    -> []-               (x:_) -> x : mfix (tail . f)---- | @since 4.9.0.0-instance MonadFix NonEmpty where-  mfix f = case fix (f . neHead) of-             ~(x :| _) -> x :| mfix (neTail . f)-    where-      neHead ~(a :| _) = a-      neTail ~(_ :| as) = as---- | @since 2.01-instance MonadFix IO where-    mfix = fixIO---- | @since 2.01-instance MonadFix ((->) r) where-    mfix f = \ r -> let a = f a r in a---- | @since 4.3.0.0-instance MonadFix (Either e) where-    mfix f = let a = f (unRight a) in a-             where unRight (Right x) = x-                   unRight (Left  _) = errorWithoutStackTrace "mfix Either: Left"---- | @since 2.01-instance MonadFix (ST s) where-        mfix = fixST---- Instances of Data.Monoid wrappers---- | @since 4.8.0.0-instance MonadFix Dual where-    mfix f   = Dual (fix (getDual . f))---- | @since 4.8.0.0-instance MonadFix Sum where-    mfix f   = Sum (fix (getSum . f))---- | @since 4.8.0.0-instance MonadFix Product where-    mfix f   = Product (fix (getProduct . f))---- | @since 4.8.0.0-instance MonadFix First where-    mfix f   = First (mfix (getFirst . f))---- | @since 4.8.0.0-instance MonadFix Last where-    mfix f   = Last (mfix (getLast . f))---- | @since 4.8.0.0-instance MonadFix f => MonadFix (Alt f) where-    mfix f   = Alt (mfix (getAlt . f))---- | @since 4.12.0.0-instance MonadFix f => MonadFix (Ap f) where-    mfix f   = Ap (mfix (getAp . f))---- Instances for GHC.Generics--- | @since 4.9.0.0-instance MonadFix Par1 where-    mfix f = Par1 (fix (unPar1 . f))---- | @since 4.9.0.0-instance MonadFix f => MonadFix (Rec1 f) where-    mfix f = Rec1 (mfix (unRec1 . f))---- | @since 4.9.0.0-instance MonadFix f => MonadFix (M1 i c f) where-    mfix f = M1 (mfix (unM1. f))---- | @since 4.9.0.0-instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where-    mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))-      where-        fstP (a :*: _) = a-        sndP (_ :*: b) = b---- Instances for Data.Ord---- | @since 4.12.0.0-instance MonadFix Down where-    mfix f = Down (fix (getDown . f))
− Control/Monad/IO/Class.hs 
@@ -1,71 +0,0 @@-{-# 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.-    -- This allows us to run IO computations in any monadic stack, so long as it supports these kinds of operations-    -- (i.e. 'IO' is the base monad for the stack).-    ---    -- === __Example__-    ---    ---    -- > import Control.Monad.Trans.State -- from the "transformers" library-    -- >-    -- > printState :: Show s => StateT s IO ()-    -- > printState = do-    -- >   state <- get-    -- >   liftIO $ print state-    ---    ---    -- Had we omitted @'liftIO'@, we would have ended up with this error:-    ---    -- > • Couldn't match type ‘IO’ with ‘StateT s IO’-    -- >  Expected type: StateT s IO ()-    -- >    Actual type: IO ()-    ---    -- The important part here is the mismatch between @StateT s IO ()@ and @'IO' ()@.-    ---    -- Luckily, we know of a function that takes an @'IO' a@ and returns an @(m a)@: @'liftIO'@,-    -- enabling us to run the program and see the expected results:-    ---    -- @-    -- > evalStateT printState "hello"-    -- "hello"-    ---    -- > evalStateT printState 3-    -- 3-    -- @-    ---    liftIO :: IO a -> m a---- | @since 4.9.0.0-instance MonadIO IO where-    liftIO = id-
− Control/Monad/Instances.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Instances--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ /This module is DEPRECATED and will be removed in the future!/------ 'Functor' and 'Monad' instances for @(->) r@ and--- 'Functor' instances for @(,) a@ and @'Either' a@.--module Control.Monad.Instances {-# DEPRECATED "This module now contains no instances and will be removed in the future" #-} -- deprecated in 7.8-    (Functor(..),Monad(..)) where
− Control/Monad/ST.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (requires universal quantification for runST)------ This library provides support for /strict/ state threads, as--- described in the PLDI \'94 paper by John Launchbury and Simon Peyton--- Jones /Lazy Functional State Threads/.------ References (variables) that can be used within the @ST@ monad are--- provided by "Data.STRef", and arrays are provided by--- [Data.Array.ST](https://hackage.haskell.org/package/array/docs/Data-Array-ST.html).---------------------------------------------------------------------------------module Control.Monad.ST (-        -- * The 'ST' Monad-        ST,             -- abstract, instance of Functor, Monad, Typeable.-        runST,-        fixST,--        -- * Converting 'ST' to 'IO'-        RealWorld,              -- abstract-        stToIO,-    ) where--import Control.Monad.ST.Imp-
− Control/Monad/ST/Imp.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Unsafe #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Imp--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (requires universal quantification for runST)------ This library provides support for /strict/ state threads, as--- described in the PLDI \'94 paper by John Launchbury and Simon Peyton--- Jones /Lazy Functional State Threads/.-----------------------------------------------------------------------------------module Control.Monad.ST.Imp (-        -- * The 'ST' Monad-        ST,             -- abstract, instance of Functor, Monad, Typeable.-        runST,-        fixST,--        -- * Converting 'ST' to 'Prelude.IO'-        RealWorld,              -- abstract-        stToIO,--        -- * Unsafe operations-        unsafeInterleaveST,-        unsafeDupableInterleaveST,-        unsafeIOToST,-        unsafeSTToIO-    ) where--import GHC.ST           ( ST, runST, unsafeInterleaveST-                        , unsafeDupableInterleaveST )-import GHC.Base         ( RealWorld, ($), return )-import GHC.IO           ( stToIO, unsafeIOToST, unsafeSTToIO-                        , unsafeDupableInterleaveIO )-import GHC.MVar         ( readMVar, putMVar, newEmptyMVar )-import Control.Exception.Base-                        ( catch, throwIO, NonTermination (..)-                        , BlockedIndefinitelyOnMVar (..) )---- | Allow the result of an 'ST' computation to be used (lazily)--- inside the computation.------ Note that if @f@ is strict, @'fixST' f = _|_@.-fixST :: (a -> ST s a) -> ST s a--- See Note [fixST]-fixST k = unsafeIOToST $ do-    m <- newEmptyMVar-    ans <- unsafeDupableInterleaveIO-             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->-                                    throwIO NonTermination)-    result <- unsafeSTToIO (k ans)-    putMVar m result-    return result--{- Note [fixST]-   ~~~~~~~~~~~~--For many years, we implemented fixST much like a pure fixpoint,-using liftST:--  fixST :: (a -> ST s a) -> ST s a-  fixST k = ST $ \ s ->-      let ans       = liftST (k r) s-          STret _ r = ans-      in-      case ans of STret s' x -> (# s', x #)--We knew that lazy blackholing could cause the computation to be re-run if the-result was demanded strictly, but we thought that would be okay in the case of-ST. However, that is not the case (see #15349). Notably, the first time-the computation is executed, it may mutate variables that cause it to behave-*differently* the second time it's run. That may allow it to terminate when it-should not. More frighteningly, Arseniy Alekseyev produced a somewhat contrived-example ( https://mail.haskell.org/pipermail/libraries/2018-July/028889.html )-demonstrating that it can break reasonable assumptions in "trustworthy" code,-causing a memory safety violation. So now we implement fixST much like we do-fixIO. See also the implementation notes for fixIO. Simon Marlow wondered-whether we could get away with an IORef instead of an MVar. I believe we-cannot. The function passed to fixST may spark a parallel computation that-demands the final result. Such a computation should block until the final-result is available.--}
− Control/Monad/ST/Lazy.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Lazy--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires universal quantification for runST)------ This module presents an identical interface to "Control.Monad.ST",--- except that the monad delays evaluation of state operations until--- a value depending on them is required.-----------------------------------------------------------------------------------module Control.Monad.ST.Lazy (-        -- * The 'ST' monad-        ST,-        runST,-        fixST,--        -- * Converting between strict and lazy 'ST'-        strictToLazyST, lazyToStrictST,--        -- * Converting 'ST' To 'IO'-        RealWorld,-        stToIO,-    ) where--import Control.Monad.ST.Lazy.Imp-
− Control/Monad/ST/Lazy/Imp.hs 
@@ -1,257 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Lazy.Imp--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires universal quantification for runST)------ This module presents an identical interface to "Control.Monad.ST",--- except that the monad delays evaluation of 'ST' operations until--- a value depending on them is required.-----------------------------------------------------------------------------------module Control.Monad.ST.Lazy.Imp (-        -- * The 'ST' monad-        ST,-        runST,-        fixST,--        -- * Converting between strict and lazy 'ST'-        strictToLazyST, lazyToStrictST,--        -- * Converting 'ST' To 'IO'-        RealWorld,-        stToIO,--        -- * Unsafe operations-        unsafeInterleaveST,-        unsafeIOToST-    ) where--import Control.Monad.Fix--import qualified Control.Monad.ST as ST-import qualified Control.Monad.ST.Unsafe as ST--import qualified GHC.ST-import GHC.Base---- | The lazy @'ST'@ monad.--- The ST monad allows for destructive updates, but is escapable (unlike @IO@).--- A computation of type @'ST' s a@ returns a value of type @a@, and--- executes in "thread" @s@. The @s@ parameter is either------ * an uninstantiated type variable (inside invocations of 'runST'), or------ * 'RealWorld' (inside invocations of 'stToIO').------ It serves to keep the internal states of different invocations of--- 'runST' separate from each other and from invocations of 'stToIO'.------ The '>>=' and '>>' operations are not strict in the state.  For example,------ @'runST' (writeSTRef _|_ v >>= readSTRef _|_ >> return 2) = 2@-newtype ST s a = ST { unST :: State s -> (a, State s) }---- A lifted state token. This can be imagined as a moment in the timeline--- of a lazy state thread. Forcing the token forces all delayed actions in--- the thread up until that moment to be performed.-data State s = S# (State# s)--{- Note [Lazy ST and multithreading]--We used to imagine that passing a polymorphic state token was all that we-needed to keep state threads separate (see Launchbury and Peyton Jones, 1994:-https://www.microsoft.com/en-us/research/publication/lazy-functional-state-threads/).-But this breaks down in the face of concurrency (see #11760). Whereas a strict-ST computation runs to completion before producing anything, a value produced-by running a lazy ST computation may contain a thunk that, when forced, will-lead to further stateful computations. If such a thunk is entered by more than-one thread, then they may both read from and write to the same references and-arrays, interfering with each other. To work around this, any time we lazily-suspend execution of a lazy ST computation, we bind the result pair to a-NOINLINE binding (ensuring that it is not duplicated) and calculate that-pair using (unsafePerformIO . evaluate), ensuring that only one thread will-enter the thunk. We still use lifted state tokens to actually drive execution,-so in these cases we effectively deal with *two* state tokens: the lifted-one we get from the previous computation, and the unlifted one we pull out of-thin air. -}--{- Note [Lazy ST: not producing lazy pairs]--The fixST and strictToLazyST functions used to construct functions that-produced lazy pairs. Why don't we need that laziness? The ST type is kept-abstract, so no one outside this module can ever get their hands on a (result,-State s) pair. We ourselves never match on such pairs when performing ST-computations unless we also force one of their components. So no one should be-able to detect the change. By refraining from producing such thunks (which-reference delayed ST computations), we avoid having to ask whether we have to-wrap them up with unsafePerformIO. See Note [Lazy ST and multithreading]. -}---- | This is a terrible hack to prevent a thunk from being entered twice.--- Simon Peyton Jones would very much like to be rid of it.-noDup :: a -> a-noDup a = runRW# (\s ->-  case noDuplicate# s of-    _ -> a)---- | @since 2.01-instance Functor (ST s) where-    fmap f m = ST $ \ s ->-      let-        -- See Note [Lazy ST and multithreading]-        {-# NOINLINE res #-}-        res = noDup (unST m s)-        (r,new_s) = res-      in-        (f r,new_s)--    x <$ m = ST $ \ s ->-      let-        {-# NOINLINE s' #-}-        -- See Note [Lazy ST and multithreading]-        s' = noDup (snd (unST m s))-      in (x, s')---- | @since 2.01-instance Applicative (ST s) where-    pure a = ST $ \ s -> (a,s)--    fm <*> xm = ST $ \ s ->-       let-         {-# NOINLINE res1 #-}-         !res1 = unST fm s-         !(f, s') = res1--         {-# NOINLINE res2 #-}-         -- See Note [Lazy ST and multithreading]-         res2 = noDup (unST xm s')-         (x, s'') = res2-       in (f x, s'')-    -- Why can we use a strict binding for res1? If someone-    -- forces the (f x, s'') pair, then they must need-    -- f or s''. To get s'', they need s'.--    liftA2 f m n = ST $ \ s ->-      let-        {-# NOINLINE res1 #-}-        -- See Note [Lazy ST and multithreading]-        res1 = noDup (unST m s)-        (x, s') = res1--        {-# NOINLINE res2 #-}-        res2 = noDup (unST n s')-        (y, s'') = res2-      in (f x y, s'')-    -- We don't get to be strict in liftA2, but we clear out a-    -- NOINLINE in comparison to the default definition, which may-    -- help the simplifier.--    m *> n = ST $ \s ->-       let-         {-# NOINLINE s' #-}-         -- See Note [Lazy ST and multithreading]-         s' = noDup (snd (unST m s))-       in unST n s'--    m <* n = ST $ \s ->-       let-         {-# NOINLINE res1 #-}-         !res1 = unST m s-         !(mr, s') = res1--         {-# NOINLINE s'' #-}-         -- See Note [Lazy ST and multithreading]-         s'' = noDup (snd (unST n s'))-       in (mr, s'')-    -- Why can we use a strict binding for res1? The same reason as-    -- in <*>. If someone demands the (mr, s'') pair, then they will-    -- force mr or s''. To get s'', they need s'.---- | @since 2.01-instance Monad (ST s) where-    (>>) = (*>)--    m >>= k = ST $ \ s ->-       let-         -- See Note [Lazy ST and multithreading]-         {-# NOINLINE res #-}-         res = noDup (unST m s)-         (r,new_s) = res-       in-         unST (k r) new_s---- | @since 4.10-instance MonadFail (ST s) where-    fail s = errorWithoutStackTrace s---- | Return the value computed by an 'ST' 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 st) = runRW# (\s -> case st (S# s) of (r, _) -> r)---- | Allow the result of an 'ST' computation to be used (lazily)--- inside the computation.--- Note that if @f@ is strict, @'fixST' f = _|_@.-fixST :: (a -> ST s a) -> ST s a-fixST m = ST (\ s ->-                let-                   q@(r,_s') = unST (m r) s-                in q)--- Why don't we need unsafePerformIO in fixST? We create a thunk, q,--- to perform a lazy state computation, and we pass a reference to that--- thunk, r, to m. Uh oh? No, I think it should be fine, because that thunk--- itself is demanded directly in the `let` body. See also--- Note [Lazy ST: not producing lazy pairs].---- | @since 2.01-instance MonadFix (ST s) where-        mfix = fixST---- ------------------------------------------------------------------------------ Strict <--> Lazy--{-|-Convert a strict 'ST' computation into a lazy one.  The strict state-thread passed to 'strictToLazyST' is not performed until the result of-the lazy state thread it returns is demanded.--}-strictToLazyST :: ST.ST s a -> ST s a-strictToLazyST (GHC.ST.ST m) = ST $ \(S# s) ->-  case m s of-    (# s', a #) -> (a, S# s')--- See Note [Lazy ST: not producing lazy pairs]--{-|-Convert a lazy 'ST' computation into a strict one.--}-lazyToStrictST :: ST s a -> ST.ST s a-lazyToStrictST (ST m) = GHC.ST.ST $ \s ->-        case (m (S# s)) of (a, S# s') -> (# s', a #)---- | A monad transformer embedding lazy 'ST' in the 'IO'--- monad.  The 'RealWorld' parameter indicates that the internal state--- used by the 'ST' computation is a special one supplied by the 'IO'--- monad, and thus distinct from those used by invocations of 'runST'.-stToIO :: ST RealWorld a -> IO a-stToIO = ST.stToIO . lazyToStrictST---- ------------------------------------------------------------------------------ Strict <--> Lazy--unsafeInterleaveST :: ST s a -> ST s a-unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST--unsafeIOToST :: IO a -> ST s a-unsafeIOToST = strictToLazyST . ST.unsafeIOToST-
− Control/Monad/ST/Lazy/Safe.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Lazy.Safe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires universal quantification for runST)------ This module presents an identical interface to "Control.Monad.ST",--- except that the monad delays evaluation of 'ST' operations until--- a value depending on them is required.------ Safe API only.-----------------------------------------------------------------------------------module Control.Monad.ST.Lazy.Safe {-# DEPRECATED "Safe is now the default, please use Control.Monad.ST.Lazy instead" #-} (-        -- * The 'ST' monad-        ST,-        runST,-        fixST,--        -- * Converting between strict and lazy 'ST'-        strictToLazyST, lazyToStrictST,--        -- * Converting 'ST' To 'IO'-        RealWorld,-        stToIO,-    ) where--import Control.Monad.ST.Lazy.Imp-
− Control/Monad/ST/Lazy/Unsafe.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE Unsafe #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Lazy.Unsafe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires universal quantification for runST)------ This module presents an identical interface to "Control.Monad.ST",--- except that the monad delays evaluation of 'ST' operations until--- a value depending on them is required.------ Unsafe API.-----------------------------------------------------------------------------------module Control.Monad.ST.Lazy.Unsafe (-        -- * Unsafe operations-        unsafeInterleaveST,-        unsafeIOToST-    ) where--import Control.Monad.ST.Lazy.Imp-
− Control/Monad/ST/Safe.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Safe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (requires universal quantification for runST)------ This library provides support for /strict/ state threads, as--- described in the PLDI \'94 paper by John Launchbury and Simon Peyton--- Jones /Lazy Functional State Threads/.------ Safe API Only.-----------------------------------------------------------------------------------module Control.Monad.ST.Safe {-# DEPRECATED "Safe is now the default, please use Control.Monad.ST instead" #-} (-        -- * The 'ST' Monad-        ST,             -- abstract-        runST,-        fixST,--        -- * Converting 'ST' to 'IO'-        RealWorld,              -- abstract-        stToIO,-    ) where--import Control.Monad.ST.Imp-
− Control/Monad/ST/Strict.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Strict--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires universal quantification for runST)------ The strict ST monad (re-export of "Control.Monad.ST")-----------------------------------------------------------------------------------module Control.Monad.ST.Strict (-        module Control.Monad.ST-  ) where--import Control.Monad.ST-
− Control/Monad/ST/Unsafe.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE Unsafe #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.ST.Unsafe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (requires universal quantification for runST)------ This library provides support for /strict/ state threads, as--- described in the PLDI \'94 paper by John Launchbury and Simon Peyton--- Jones /Lazy Functional State Threads/.------ Unsafe API.-----------------------------------------------------------------------------------module Control.Monad.ST.Unsafe (-        -- * Unsafe operations-        unsafeInterleaveST,-        unsafeDupableInterleaveST,-        unsafeIOToST,-        unsafeSTToIO-    ) where--import Control.Monad.ST.Imp-
− Control/Monad/Zip.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Zip--- Copyright   :  (c) Nils Schweinsberg 2011,---                (c) George Giorgidze 2011---                (c) University Tuebingen 2011--- License     :  BSD-style (see the file libraries/base/LICENSE)--- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Monadic zipping (used for monad comprehensions)-----------------------------------------------------------------------------------module Control.Monad.Zip where--import Control.Monad (liftM, liftM2)-import Data.Functor.Identity-import Data.Monoid-import Data.Ord ( Down(..) )-import Data.Proxy-import qualified Data.List.NonEmpty as NE-import GHC.Generics-import GHC.Tuple (Solo (..))---- | Instances should satisfy the laws:------ [Naturality]------     @'liftM' (f 'Control.Arrow.***' g) ('mzip' ma mb)---         = 'mzip' ('liftM' f ma) ('liftM' g mb)@------ [Information Preservation]------     @'liftM' ('Prelude.const' ()) ma = 'liftM' ('Prelude.const' ()) mb@---         implies---     @'munzip' ('mzip' ma mb) = (ma, mb)@----class Monad m => MonadZip m where-    {-# MINIMAL mzip | mzipWith #-}--    mzip :: m a -> m b -> m (a,b)-    mzip = mzipWith (,)--    mzipWith :: (a -> b -> c) -> m a -> m b -> m c-    mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)--    munzip :: m (a,b) -> (m a, m b)-    munzip mab = (liftM fst mab, liftM snd mab)-    -- munzip is a member of the class because sometimes-    -- you can implement it more efficiently than the-    -- above default code.  See #4370 comment by giorgidze---- | @since 4.3.1.0-instance MonadZip [] where-    mzip     = zip-    mzipWith = zipWith-    munzip   = unzip---- | @since 4.9.0.0-instance MonadZip NE.NonEmpty where-  mzip     = NE.zip-  mzipWith = NE.zipWith-  munzip   = NE.unzip---- | @since 4.8.0.0-instance MonadZip Identity where-    mzipWith                 = liftM2-    munzip (Identity (a, b)) = (Identity a, Identity b)---- | @since 4.15.0.0-instance MonadZip Solo where-    mzipWith = liftM2-    munzip (Solo (a, b)) = (Solo a, Solo b)---- | @since 4.8.0.0-instance MonadZip Dual where-    -- Cannot use coerce, it's unsafe-    mzipWith = liftM2---- | @since 4.8.0.0-instance MonadZip Sum where-    mzipWith = liftM2---- | @since 4.8.0.0-instance MonadZip Product where-    mzipWith = liftM2---- | @since 4.8.0.0-instance MonadZip Maybe where-    mzipWith = liftM2---- | @since 4.8.0.0-instance MonadZip First where-    mzipWith = liftM2---- | @since 4.8.0.0-instance MonadZip Last where-    mzipWith = liftM2---- | @since 4.8.0.0-instance MonadZip f => MonadZip (Alt f) where-    mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb)---- | @since 4.9.0.0-instance MonadZip Proxy where-    mzipWith _ _ _ = Proxy---- Instances for GHC.Generics--- | @since 4.9.0.0-instance MonadZip U1 where-    mzipWith _ _ _ = U1---- | @since 4.9.0.0-instance MonadZip Par1 where-    mzipWith = liftM2---- | @since 4.9.0.0-instance MonadZip f => MonadZip (Rec1 f) where-    mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb)---- | @since 4.9.0.0-instance MonadZip f => MonadZip (M1 i c f) where-    mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb)---- | @since 4.9.0.0-instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where-    mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2---- instances for Data.Ord---- | @since 4.12.0.0-instance MonadZip Down where-    mzipWith = liftM2
− Data/Bifoldable.hs 
@@ -1,1020 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Bifoldable--- Copyright   :  (C) 2011-2016 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ @since 4.10.0.0------------------------------------------------------------------------------module Data.Bifoldable-  ( Bifoldable(..)-  , bifoldr'-  , bifoldr1-  , bifoldrM-  , bifoldl'-  , bifoldl1-  , bifoldlM-  , bitraverse_-  , bifor_-  , bimapM_-  , biforM_-  , bimsum-  , bisequenceA_-  , bisequence_-  , biasum-  , biList-  , binull-  , bilength-  , bielem-  , bimaximum-  , biminimum-  , bisum-  , biproduct-  , biconcat-  , biconcatMap-  , biand-  , bior-  , biany-  , biall-  , bimaximumBy-  , biminimumBy-  , binotElem-  , bifind-  ) where--import Control.Applicative-import Data.Functor.Utils (Max(..), Min(..), (#.))-import Data.Maybe (fromMaybe)-import Data.Monoid-import GHC.Generics (K1(..))---- $setup--- >>> import Prelude--- >>> import Data.Char--- >>> import Data.Monoid (Product (..), Sum (..))--- >>> data BiList a b = BiList [a] [b]--- >>> instance Bifoldable BiList where bifoldr f g z (BiList as bs) = foldr f (foldr g z bs) as---- | 'Bifoldable' identifies foldable structures with two different varieties--- of elements (as opposed to 'Foldable', which has one variety of element).--- Common examples are 'Either' and @(,)@:------ > instance Bifoldable Either where--- >   bifoldMap f _ (Left  a) = f a--- >   bifoldMap _ g (Right b) = g b--- >--- > instance Bifoldable (,) where--- >   bifoldr f g z (a, b) = f a (g b z)------ Some examples below also use the following BiList to showcase empty--- Bifoldable behaviors when relevant ('Either' and '(,)' containing always exactly--- resp. 1 and 2 elements):------ > data BiList a b = BiList [a] [b]--- >--- > instance Bifoldable BiList where--- >   bifoldr f g z (BiList as bs) = foldr f (foldr g z bs) as------ A minimal 'Bifoldable' definition consists of either 'bifoldMap' or--- 'bifoldr'. When defining more than this minimal set, one should ensure--- that the following identities hold:------ @--- 'bifold' ≡ 'bifoldMap' 'id' 'id'--- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'--- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z--- @------ If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy:------ @--- 'bifoldMap' f g ≡ 'bifold' . 'Data.Bifunctor.bimap' f g--- @------ which implies that------ @--- 'bifoldMap' f g . 'Data.Bifunctor.bimap' h i ≡ 'bifoldMap' (f . h) (g . i)--- @------ @since 4.10.0.0-class Bifoldable p where-  {-# MINIMAL bifoldr | bifoldMap #-}--  -- | Combines the elements of a structure using a monoid.-  ---  -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@-  ---  -- ==== __Examples__-  ---  -- Basic usage:-  ---  -- >>> bifold (Right [1, 2, 3])-  -- [1,2,3]-  ---  -- >>> bifold (Left [5, 6])-  -- [5,6]-  ---  -- >>> bifold ([1, 2, 3], [4, 5])-  -- [1,2,3,4,5]-  ---  -- >>> bifold (Product 6, Product 7)-  -- Product {getProduct = 42}-  ---  -- >>> bifold (Sum 6, Sum 7)-  -- Sum {getSum = 13}-  ---  -- @since 4.10.0.0-  bifold :: Monoid m => p m m -> m-  bifold = bifoldMap id id--  -- | Combines the elements of a structure, given ways of mapping them to a-  -- common monoid.-  ---  -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@-  ---  -- ==== __Examples__-  ---  -- Basic usage:-  ---  -- >>> bifoldMap (take 3) (fmap digitToInt) ([1..], "89")-  -- [1,2,3,8,9]-  ---  -- >>> bifoldMap (take 3) (fmap digitToInt) (Left [1..])-  -- [1,2,3]-  ---  -- >>> bifoldMap (take 3) (fmap digitToInt) (Right "89")-  -- [8,9]-  ---  -- @since 4.10.0.0-  bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m-  bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty--  -- | Combines the elements of a structure in a right associative manner.-  -- Given a hypothetical function @toEitherList :: p a b -> [Either a b]@-  -- yielding a list of all elements of a structure in order, the following-  -- would hold:-  ---  -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@-  ---  -- ==== __Examples__-  ---  -- Basic usage:-  ---  -- @-  -- > bifoldr (+) (*) 3 (5, 7)-  -- 26 -- 5 + (7 * 3)-  ---  -- > bifoldr (+) (*) 3 (7, 5)-  -- 22 -- 7 + (5 * 3)-  ---  -- > bifoldr (+) (*) 3 (Right 5)-  -- 15 -- 5 * 3-  ---  -- > bifoldr (+) (*) 3 (Left 5)-  -- 8 -- 5 + 3-  -- @-  ---  -- @since 4.10.0.0-  bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c-  bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z--  -- | Combines the elements of a structure in a left associative manner. Given-  -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a-  -- list of all elements of a structure in order, the following would hold:-  ---  -- @'bifoldl' f g z-  --     ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@-  ---  -- Note that if you want an efficient left-fold, you probably want to use-  -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not-  -- force the "inner" results, resulting in a thunk chain which then must be-  -- evaluated from the outside-in.-  ---  -- ==== __Examples__-  ---  -- Basic usage:-  ---  -- @-  -- > bifoldl (+) (*) 3 (5, 7)-  -- 56 -- (5 + 3) * 7-  ---  -- > bifoldl (+) (*) 3 (7, 5)-  -- 50 -- (7 + 3) * 5-  ---  -- > bifoldl (+) (*) 3 (Right 5)-  -- 15 -- 5 * 3-  ---  -- > bifoldl (+) (*) 3 (Left 5)-  -- 8 -- 5 + 3-  -- @-  ---  -- @since 4.10.0.0-  bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c-  bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f)-                                                (Dual . Endo . flip g) t)) z---- | @since 4.10.0.0-instance Bifoldable (,) where-  bifoldMap f g ~(a, b) = f a `mappend` g b---- | @since 4.10.0.0-instance Bifoldable Const where-  bifoldMap f _ (Const a) = f a---- | @since 4.10.0.0-instance Bifoldable (K1 i) where-  bifoldMap f _ (K1 c) = f c---- | @since 4.10.0.0-instance Bifoldable ((,,) x) where-  bifoldMap f g ~(_,a,b) = f a `mappend` g b---- | @since 4.10.0.0-instance Bifoldable ((,,,) x y) where-  bifoldMap f g ~(_,_,a,b) = f a `mappend` g b---- | @since 4.10.0.0-instance Bifoldable ((,,,,) x y z) where-  bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b---- | @since 4.10.0.0-instance Bifoldable ((,,,,,) x y z w) where-  bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b---- | @since 4.10.0.0-instance Bifoldable ((,,,,,,) x y z w v) where-  bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b---- | @since 4.10.0.0-instance Bifoldable Either where-  bifoldMap f _ (Left a) = f a-  bifoldMap _ g (Right b) = g b---- | As 'bifoldr', but strict in the result of the reduction functions at each--- step.------ @since 4.10.0.0-bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c-bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where-  f' k x z = k $! f x z-  g' k x z = k $! g x z---- | A variant of 'bifoldr' that has no base case,--- and thus may only be applied to non-empty structures.------ ==== __Examples__------ Basic usage:------ >>> bifoldr1 (+) (5, 7)--- 12------ >>> bifoldr1 (+) (Right 7)--- 7------ >>> bifoldr1 (+) (Left 5)--- 5------ @--- > bifoldr1 (+) (BiList [1, 2] [3, 4])--- 10 -- 1 + (2 + (3 + 4))--- @------ >>> bifoldr1 (+) (BiList [1, 2] [])--- 3------ On empty structures, this function throws an exception:------ >>> bifoldr1 (+) (BiList [] [])--- *** Exception: bifoldr1: empty structure--- ...------ @since 4.10.0.0-bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a-bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure")-                  (bifoldr mbf mbf Nothing xs)-  where-    mbf x m = Just (case m of-                      Nothing -> x-                      Just y  -> f x y)---- | Right associative monadic bifold over a structure.------ @since 4.10.0.0-bifoldrM :: (Bifoldable t, Monad m)-         => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c-bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where-  f' k x z = f x z >>= k-  g' k x z = g x z >>= k---- | As 'bifoldl', but strict in the result of the reduction functions at each--- step.------ This ensures that each step of the bifold 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 structure to--- a single, monolithic result (e.g., 'bilength').------ @since 4.10.0.0-bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a-bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where-  f' x k z = k $! f z x-  g' x k z = k $! g z x---- | A variant of 'bifoldl' that has no base case,--- and thus may only be applied to non-empty structures.------ ==== __Examples__------ Basic usage:------ >>> bifoldl1 (+) (5, 7)--- 12------ >>> bifoldl1 (+) (Right 7)--- 7------ >>> bifoldl1 (+) (Left 5)--- 5------ @--- > bifoldl1 (+) (BiList [1, 2] [3, 4])--- 10 -- ((1 + 2) + 3) + 4--- @------ >>> bifoldl1 (+) (BiList [1, 2] [])--- 3------ On empty structures, this function throws an exception:------ >>> bifoldl1 (+) (BiList [] [])--- *** Exception: bifoldl1: empty structure--- ...------ @since 4.10.0.0-bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a-bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure")-                  (bifoldl mbf mbf Nothing xs)-  where-    mbf m y = Just (case m of-                      Nothing -> y-                      Just x  -> f x y)---- | Left associative monadic bifold over a structure.------ ==== __Examples__------ Basic usage:------ >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 ("Hello", True)--- "Hello"--- "True"--- 42------ >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 (Right True)--- "True"--- 42------ >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 (Left "Hello")--- "Hello"--- 42------ @since 4.10.0.0-bifoldlM :: (Bifoldable t, Monad m)-         => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a-bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where-  f' x k z = f z x >>= k-  g' x k z = g z x >>= k---- | Map each element of a structure using one of two actions, evaluate these--- actions from left to right, and ignore the results. For a version that--- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'.------ ==== __Examples__------ Basic usage:------ >>> bitraverse_ print (print . show) ("Hello", True)--- "Hello"--- "True"------ >>> bitraverse_ print (print . show) (Right True)--- "True"------ >>> bitraverse_ print (print . show) (Left "Hello")--- "Hello"------ @since 4.10.0.0-bitraverse_ :: (Bifoldable t, Applicative f)-            => (a -> f c) -> (b -> f d) -> t a b -> f ()-bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())---- | As 'bitraverse_', but with the structure as the primary argument. For a--- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'.------ ==== __Examples__------ Basic usage:------ >>> bifor_ ("Hello", True) print (print . show)--- "Hello"--- "True"------ >>> bifor_ (Right True) print (print . show)--- "True"------ >>> bifor_ (Left "Hello") print (print . show)--- "Hello"------ @since 4.10.0.0-bifor_ :: (Bifoldable t, Applicative f)-       => t a b -> (a -> f c) -> (b -> f d) -> f ()-bifor_ t f g = bitraverse_ f g t---- | Alias for 'bitraverse_'.------ @since 4.10.0.0-bimapM_ :: (Bifoldable t, Applicative f)-        => (a -> f c) -> (b -> f d) -> t a b -> f ()-bimapM_ = bitraverse_---- | Alias for 'bifor_'.------ @since 4.10.0.0-biforM_ :: (Bifoldable t, Applicative f)-        => t a b ->  (a -> f c) -> (b -> f d) -> f ()-biforM_ = bifor_---- | Alias for 'bisequence_'.------ @since 4.10.0.0-bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()-bisequenceA_ = bisequence_---- | Evaluate each action in the structure from left to right, and ignore the--- results. For a version that doesn't ignore the results, see--- 'Data.Bitraversable.bisequence'.------ ==== __Examples__------ Basic usage:------ >>> bisequence_ (print "Hello", print "World")--- "Hello"--- "World"------ >>> bisequence_ (Left (print "Hello"))--- "Hello"------ >>> bisequence_ (Right (print "World"))--- "World"------ @since 4.10.0.0-bisequence_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()-bisequence_ = bifoldr (*>) (*>) (pure ())---- | The sum of a collection of actions, generalizing 'biconcat'.------ ==== __Examples__------ Basic usage:------ >>> biasum (Nothing, Nothing)--- Nothing------ >>> biasum (Nothing, Just 42)--- Just 42------ >>> biasum (Just 18, Nothing)--- Just 18------ >>> biasum (Just 18, Just 42)--- Just 18------ @since 4.10.0.0-biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a-biasum = bifoldr (<|>) (<|>) empty---- | Alias for 'biasum'.------ @since 4.10.0.0-bimsum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a-bimsum = biasum---- | Collects the list of elements of a structure, from left to right.------ ==== __Examples__------ Basic usage:------ >>> biList (18, 42)--- [18,42]------ >>> biList (Left 18)--- [18]------ @since 4.10.0.0-biList :: Bifoldable t => t a a -> [a]-biList = bifoldr (:) (:) []---- | Test whether the structure is empty.------ ==== __Examples__------ Basic usage:------ >>> binull (18, 42)--- False------ >>> binull (Right 42)--- False------ >>> binull (BiList [] [])--- True------ @since 4.10.0.0-binull :: Bifoldable t => t a b -> Bool-binull = bifoldr (\_ _ -> False) (\_ _ -> False) True---- | Returns the size/length of a finite structure as an 'Int'.------ ==== __Examples__------ Basic usage:------ >>> bilength (True, 42)--- 2------ >>> bilength (Right 42)--- 1------ >>> bilength (BiList [1,2,3] [4,5])--- 5------ >>> bilength (BiList [] [])--- 0------ On infinite structures, this function hangs:------ @--- > bilength (BiList [1..] [])--- * Hangs forever *--- @------ @since 4.10.0.0-bilength :: Bifoldable t => t a b -> Int-bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0---- | Does the element occur in the structure?------ ==== __Examples__------ Basic usage:------ >>> bielem 42 (17, 42)--- True------ >>> bielem 42 (17, 43)--- False------ >>> bielem 42 (Left 42)--- True------ >>> bielem 42 (Right 13)--- False------ >>> bielem 42 (BiList [1..5] [1..100])--- True------ >>> bielem 42 (BiList [1..5] [1..41])--- False------ @since 4.10.0.0-bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool-bielem x = biany (== x) (== x)---- | Reduces a structure of lists to the concatenation of those lists.------ ==== __Examples__------ Basic usage:------ >>> biconcat ([1, 2, 3], [4, 5])--- [1,2,3,4,5]------ >>> biconcat (Left [1, 2, 3])--- [1,2,3]------ >>> biconcat (BiList [[1, 2, 3, 4, 5], [6, 7, 8]] [[9]])--- [1,2,3,4,5,6,7,8,9]------ @since 4.10.0.0-biconcat :: Bifoldable t => t [a] [a] -> [a]-biconcat = bifold---- | The largest element of a non-empty structure.------ ==== __Examples__------ Basic usage:------ >>> bimaximum (42, 17)--- 42------ >>> bimaximum (Right 42)--- 42------ >>> bimaximum (BiList [13, 29, 4] [18, 1, 7])--- 29------ >>> bimaximum (BiList [13, 29, 4] [])--- 29------ On empty structures, this function throws an exception:------ >>> bimaximum (BiList [] [])--- *** Exception: bimaximum: empty structure--- ...------ @since 4.10.0.0-bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a-bimaximum = fromMaybe (error "bimaximum: empty structure") .-    getMax . bifoldMap mj mj-  where mj = Max #. (Just :: a -> Maybe a)---- | The least element of a non-empty structure.------ ==== __Examples__------ Basic usage:------ >>> biminimum (42, 17)--- 17------ >>> biminimum (Right 42)--- 42------ >>> biminimum (BiList [13, 29, 4] [18, 1, 7])--- 1------ >>> biminimum (BiList [13, 29, 4] [])--- 4------ On empty structures, this function throws an exception:------ >>> biminimum (BiList [] [])--- *** Exception: biminimum: empty structure--- ...------ @since 4.10.0.0-biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a-biminimum = fromMaybe (error "biminimum: empty structure") .-    getMin . bifoldMap mj mj-  where mj = Min #. (Just :: a -> Maybe a)---- | The 'bisum' function computes the sum of the numbers of a structure.------ ==== __Examples__------ Basic usage:------ >>> bisum (42, 17)--- 59------ >>> bisum (Right 42)--- 42------ >>> bisum (BiList [13, 29, 4] [18, 1, 7])--- 72------ >>> bisum (BiList [13, 29, 4] [])--- 46------ >>> bisum (BiList [] [])--- 0------ @since 4.10.0.0-bisum :: (Bifoldable t, Num a) => t a a -> a-bisum = getSum #. bifoldMap Sum Sum---- | The 'biproduct' function computes the product of the numbers of a--- structure.------ ==== __Examples__------ Basic usage:------ >>> biproduct (42, 17)--- 714------ >>> biproduct (Right 42)--- 42------ >>> biproduct (BiList [13, 29, 4] [18, 1, 7])--- 190008------ >>> biproduct (BiList [13, 29, 4] [])--- 1508------ >>> biproduct (BiList [] [])--- 1------ @since 4.10.0.0-biproduct :: (Bifoldable t, Num a) => t a a -> a-biproduct = getProduct #. bifoldMap Product Product---- | Given a means of mapping the elements of a structure to lists, computes the--- concatenation of all such lists in order.------ ==== __Examples__------ Basic usage:------ >>> biconcatMap (take 3) (fmap digitToInt) ([1..], "89")--- [1,2,3,8,9]------ >>> biconcatMap (take 3) (fmap digitToInt) (Left [1..])--- [1,2,3]------ >>> biconcatMap (take 3) (fmap digitToInt) (Right "89")--- [8,9]------ @since 4.10.0.0-biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c]-biconcatMap = bifoldMap---- | 'biand' returns the conjunction of a container of Bools.  For the--- result to be 'True', the container must be finite; 'False', however,--- results from a 'False' value finitely far from the left end.------ ==== __Examples__------ Basic usage:------ >>> biand (True, False)--- False------ >>> biand (True, True)--- True------ >>> biand (Left True)--- True------ Empty structures yield 'True':------ >>> biand (BiList [] [])--- True------ A 'False' value finitely far from the left end yields 'False' (short circuit):------ >>> biand (BiList [True, True, False, True] (repeat True))--- False------ A 'False' value infinitely far from the left end hangs:------ @--- > biand (BiList (repeat True) [False])--- * Hangs forever *--- @------ An infinitely 'True' value hangs:------ @--- > biand (BiList (repeat True) [])--- * Hangs forever *--- @------ @since 4.10.0.0-biand :: Bifoldable t => t Bool Bool -> Bool-biand = getAll #. bifoldMap All All---- | 'bior' returns the disjunction of a container of Bools.  For the--- result to be 'False', the container must be finite; 'True', however,--- results from a 'True' value finitely far from the left end.------ ==== __Examples__------ Basic usage:------ >>> bior (True, False)--- True------ >>> bior (False, False)--- False------ >>> bior (Left True)--- True------ Empty structures yield 'False':------ >>> bior (BiList [] [])--- False------ A 'True' value finitely far from the left end yields 'True' (short circuit):------ >>> bior (BiList [False, False, True, False] (repeat False))--- True------ A 'True' value infinitely far from the left end hangs:------ @--- > bior (BiList (repeat False) [True])--- * Hangs forever *--- @------ An infinitely 'False' value hangs:------ @--- > bior (BiList (repeat False) [])--- * Hangs forever *--- @------ @since 4.10.0.0-bior :: Bifoldable t => t Bool Bool -> Bool-bior = getAny #. bifoldMap Any Any---- | Determines whether any element of the structure satisfies its appropriate--- predicate argument. Empty structures yield 'False'.------ ==== __Examples__------ Basic usage:------ >>> biany even isDigit (27, 't')--- False------ >>> biany even isDigit (27, '8')--- True------ >>> biany even isDigit (26, 't')--- True------ >>> biany even isDigit (Left 27)--- False------ >>> biany even isDigit (Left 26)--- True------ >>> biany even isDigit (BiList [27, 53] ['t', '8'])--- True------ Empty structures yield 'False':------ >>> biany even isDigit (BiList [] [])--- False------ @since 4.10.0.0-biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool-biany p q = getAny #. bifoldMap (Any . p) (Any . q)---- | Determines whether all elements of the structure satisfy their appropriate--- predicate argument. Empty structures yield 'True'.------ ==== __Examples__------ Basic usage:------ >>> biall even isDigit (27, 't')--- False------ >>> biall even isDigit (26, '8')--- True------ >>> biall even isDigit (Left 27)--- False------ >>> biall even isDigit (Left 26)--- True------ >>> biall even isDigit (BiList [26, 52] ['3', '8'])--- True------ Empty structures yield 'True':------ >>> biall even isDigit (BiList [] [])--- True------ @since 4.10.0.0-biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool-biall p q = getAll #. bifoldMap (All . p) (All . q)---- | The largest element of a non-empty structure with respect to the--- given comparison function.------ ==== __Examples__------ Basic usage:------ >>> bimaximumBy compare (42, 17)--- 42------ >>> bimaximumBy compare (Left 17)--- 17------ >>> bimaximumBy compare (BiList [42, 17, 23] [-5, 18])--- 42------ On empty structures, this function throws an exception:------ >>> bimaximumBy compare (BiList [] [])--- *** Exception: bifoldr1: empty structure--- ...------ @since 4.10.0.0-bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a-bimaximumBy cmp = bifoldr1 max'-  where max' x y = case cmp x y of-                        GT -> x-                        _  -> y---- | The least element of a non-empty structure with respect to the--- given comparison function.------ ==== __Examples__------ Basic usage:------ >>> biminimumBy compare (42, 17)--- 17------ >>> biminimumBy compare (Left 17)--- 17------ >>> biminimumBy compare (BiList [42, 17, 23] [-5, 18])--- -5------ On empty structures, this function throws an exception:------ >>> biminimumBy compare (BiList [] [])--- *** Exception: bifoldr1: empty structure--- ...------ @since 4.10.0.0-biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a-biminimumBy cmp = bifoldr1 min'-  where min' x y = case cmp x y of-                        GT -> y-                        _  -> x---- | 'binotElem' is the negation of 'bielem'.------ ==== __Examples__------ Basic usage:------ >>> binotElem 42 (17, 42)--- False------ >>> binotElem 42 (17, 43)--- True------ >>> binotElem 42 (Left 42)--- False------ >>> binotElem 42 (Right 13)--- True------ >>> binotElem 42 (BiList [1..5] [1..100])--- False------ >>> binotElem 42 (BiList [1..5] [1..41])--- True------ @since 4.10.0.0-binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool-binotElem x =  not . bielem x---- | The 'bifind' function takes a predicate and a structure and returns--- the leftmost element of the structure matching the predicate, or--- 'Nothing' if there is no such element.------ ==== __Examples__------ Basic usage:------ >>> bifind even (27, 53)--- Nothing------ >>> bifind even (27, 52)--- Just 52------ >>> bifind even (26, 52)--- Just 26------ Empty structures always yield 'Nothing':------ >>> bifind even (BiList [] [])--- Nothing------ @since 4.10.0.0-bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a-bifind p = getFirst . bifoldMap finder finder-  where finder x = First (if p x then Just x else Nothing)
− Data/Bifunctor.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Bifunctor--- Copyright   :  (C) 2008-2014 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ @since 4.8.0.0------------------------------------------------------------------------------module Data.Bifunctor-  ( Bifunctor(..)-  ) where--import Control.Applicative  ( Const(..) )-import GHC.Generics ( K1(..) )---- $setup--- >>> import Prelude--- >>> import Data.Char (toUpper)---- | A bifunctor is a type constructor that takes--- two type arguments and is a functor in /both/ arguments. That--- is, unlike with 'Functor', a type constructor such as 'Either'--- does not need to be partially applied for a 'Bifunctor'--- instance, and the methods in this class permit mapping--- functions over the 'Left' value or the 'Right' value,--- or both at the same time.------ Formally, the class 'Bifunctor' represents a bifunctor--- from @Hask@ -> @Hask@.------ Intuitively it is a bifunctor where both the first and second--- arguments are covariant.------ You can define a 'Bifunctor' by either defining 'bimap' or by--- defining both 'first' and 'second'.------ If you supply 'bimap', you should ensure that:------ @'bimap' 'id' 'id' ≡ 'id'@------ If you supply 'first' and 'second', ensure:------ @--- 'first' 'id' ≡ 'id'--- 'second' 'id' ≡ 'id'--- @------ If you supply both, you should also ensure:------ @'bimap' f g ≡ 'first' f '.' 'second' g@------ These ensure by parametricity:------ @--- 'bimap'  (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i--- 'first'  (f '.' g) ≡ 'first'  f '.' 'first'  g--- 'second' (f '.' g) ≡ 'second' f '.' 'second' g--- @------ @since 4.8.0.0-class Bifunctor p where-    {-# MINIMAL bimap | first, second #-}--    -- | Map over both arguments at the same time.-    ---    -- @'bimap' f g ≡ 'first' f '.' 'second' g@-    ---    -- ==== __Examples__-    -- >>> bimap toUpper (+1) ('j', 3)-    -- ('J',4)-    ---    -- >>> bimap toUpper (+1) (Left 'j')-    -- Left 'J'-    ---    -- >>> bimap toUpper (+1) (Right 3)-    -- Right 4-    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d-    bimap f g = first f . second g---    -- | Map covariantly over the first argument.-    ---    -- @'first' f ≡ 'bimap' f 'id'@-    ---    -- ==== __Examples__-    -- >>> first toUpper ('j', 3)-    -- ('J',3)-    ---    -- >>> first toUpper (Left 'j')-    -- Left 'J'-    first :: (a -> b) -> p a c -> p b c-    first f = bimap f id---    -- | Map covariantly over the second argument.-    ---    -- @'second' ≡ 'bimap' 'id'@-    ---    -- ==== __Examples__-    -- >>> second (+1) ('j', 3)-    -- ('j',4)-    ---    -- >>> second (+1) (Right 3)-    -- Right 4-    second :: (b -> c) -> p a b -> p a c-    second = bimap id------ | @since 4.8.0.0-instance Bifunctor (,) where-    bimap f g ~(a, b) = (f a, g b)---- | @since 4.8.0.0-instance Bifunctor ((,,) x1) where-    bimap f g ~(x1, a, b) = (x1, f a, g b)---- | @since 4.8.0.0-instance Bifunctor ((,,,) x1 x2) where-    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)---- | @since 4.8.0.0-instance Bifunctor ((,,,,) x1 x2 x3) where-    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)---- | @since 4.8.0.0-instance Bifunctor ((,,,,,) x1 x2 x3 x4) where-    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)---- | @since 4.8.0.0-instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where-    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)----- | @since 4.8.0.0-instance Bifunctor Either where-    bimap f _ (Left a) = Left (f a)-    bimap _ g (Right b) = Right (g b)---- | @since 4.8.0.0-instance Bifunctor Const where-    bimap f _ (Const a) = Const (f a)---- | @since 4.9.0.0-instance Bifunctor (K1 i) where-    bimap f _ (K1 c) = K1 (f c)
− Data/Bitraversable.hs 
@@ -1,304 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Bitraversable--- Copyright   :  (C) 2011-2016 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ @since 4.10.0.0------------------------------------------------------------------------------module Data.Bitraversable-  ( Bitraversable(..)-  , bisequenceA-  , bisequence-  , bimapM-  , bifor-  , biforM-  , bimapAccumL-  , bimapAccumR-  , bimapDefault-  , bifoldMapDefault-  ) where--import Control.Applicative-import Data.Bifunctor-import Data.Bifoldable-import Data.Coerce-import Data.Functor.Identity (Identity(..))-import Data.Functor.Utils (StateL(..), StateR(..))-import GHC.Generics (K1(..))---- $setup--- >>> import Prelude--- >>> import Data.Maybe--- >>> import Data.List (find)---- | 'Bitraversable' identifies bifunctorial data structures whose elements can--- be traversed in order, performing 'Applicative' or 'Monad' actions at each--- element, and collecting a result structure with the same shape.------ As opposed to 'Traversable' data structures, which have one variety of--- element on which an action can be performed, 'Bitraversable' data structures--- have two such varieties of elements.------ A definition of 'bitraverse' must satisfy the following laws:------ [Naturality]---   @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@---   for every applicative transformation @t@------ [Identity]---   @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@------ [Composition]---   @'Data.Functor.Compose.Compose' .---    'fmap' ('bitraverse' g1 g2) .---    'bitraverse' f1 f2---     ≡ 'bitraverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1)---                  ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@------ where an /applicative transformation/ is a function------ @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@------ preserving the 'Applicative' operations:------ @--- t ('pure' x) = 'pure' x--- t (f '<*>' x) = t f '<*>' t x--- @------ and the identity functor 'Identity' and composition functors--- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and--- "Data.Functor.Compose".------ Some simple examples are 'Either' and @(,)@:------ > instance Bitraversable Either where--- >   bitraverse f _ (Left x) = Left <$> f x--- >   bitraverse _ g (Right y) = Right <$> g y--- >--- > instance Bitraversable (,) where--- >   bitraverse f g (x, y) = (,) <$> f x <*> g y------ 'Bitraversable' relates to its superclasses in the following ways:------ @--- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)--- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)--- @------ These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.------ @since 4.10.0.0-class (Bifunctor t, Bifoldable t) => Bitraversable t where-  -- | Evaluates the relevant functions at each element in the structure,-  -- running the action, and builds a new structure with the same shape, using-  -- the results produced from sequencing the actions.-  ---  -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@-  ---  -- For a version that ignores the results, see 'bitraverse_'.-  ---  -- ==== __Examples__-  ---  -- Basic usage:-  ---  -- >>> bitraverse listToMaybe (find odd) (Left [])-  -- Nothing-  ---  -- >>> bitraverse listToMaybe (find odd) (Left [1, 2, 3])-  -- Just (Left 1)-  ---  -- >>> bitraverse listToMaybe (find odd) (Right [4, 5])-  -- Just (Right 5)-  ---  -- >>> bitraverse listToMaybe (find odd) ([1, 2, 3], [4, 5])-  -- Just (1,5)-  ---  -- >>> bitraverse listToMaybe (find odd) ([], [4, 5])-  -- Nothing-  ---  -- @since 4.10.0.0-  bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)-  bitraverse f g = bisequenceA . bimap f g---- | Alias for 'bisequence'.------ @since 4.10.0.0-bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)-bisequenceA = bisequence---- | Alias for 'bitraverse'.------ @since 4.10.0.0-bimapM :: (Bitraversable t, Applicative f)-       => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)-bimapM = bitraverse---- | Sequences all the actions in a structure, building a new structure with--- the same shape using the results of the actions. For a version that ignores--- the results, see 'bisequence_'.------ @'bisequence' ≡ 'bitraverse' 'id' 'id'@------ ==== __Examples__------ Basic usage:------ >>> bisequence (Just 4, Nothing)--- Nothing------ >>> bisequence (Just 4, Just 5)--- Just (4,5)------ >>> bisequence ([1, 2, 3], [4, 5])--- [(1,4),(1,5),(2,4),(2,5),(3,4),(3,5)]------ @since 4.10.0.0-bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)-bisequence = bitraverse id id---- | @since 4.10.0.0-instance Bitraversable (,) where-  bitraverse f g ~(a, b) = liftA2 (,) (f a) (g b)---- | @since 4.10.0.0-instance Bitraversable ((,,) x) where-  bitraverse f g ~(x, a, b) = liftA2 ((,,) x) (f a) (g b)---- | @since 4.10.0.0-instance Bitraversable ((,,,) x y) where-  bitraverse f g ~(x, y, a, b) = liftA2 ((,,,) x y) (f a) (g b)---- | @since 4.10.0.0-instance Bitraversable ((,,,,) x y z) where-  bitraverse f g ~(x, y, z, a, b) = liftA2 ((,,,,) x y z) (f a) (g b)---- | @since 4.10.0.0-instance Bitraversable ((,,,,,) x y z w) where-  bitraverse f g ~(x, y, z, w, a, b) = liftA2 ((,,,,,) x y z w) (f a) (g b)---- | @since 4.10.0.0-instance Bitraversable ((,,,,,,) x y z w v) where-  bitraverse f g ~(x, y, z, w, v, a, b) =-    liftA2 ((,,,,,,) x y z w v) (f a) (g b)---- | @since 4.10.0.0-instance Bitraversable Either where-  bitraverse f _ (Left a) = Left <$> f a-  bitraverse _ g (Right b) = Right <$> g b---- | @since 4.10.0.0-instance Bitraversable Const where-  bitraverse f _ (Const a) = Const <$> f a---- | @since 4.10.0.0-instance Bitraversable (K1 i) where-  bitraverse f _ (K1 c) = K1 <$> f c---- | 'bifor' is 'bitraverse' with the structure as the first argument. For a--- version that ignores the results, see 'bifor_'.------ ==== __Examples__------ Basic usage:------ >>> bifor (Left []) listToMaybe (find even)--- Nothing------ >>> bifor (Left [1, 2, 3]) listToMaybe (find even)--- Just (Left 1)------ >>> bifor (Right [4, 5]) listToMaybe (find even)--- Just (Right 4)------ >>> bifor ([1, 2, 3], [4, 5]) listToMaybe (find even)--- Just (1,4)------ >>> bifor ([], [4, 5]) listToMaybe (find even)--- Nothing------ @since 4.10.0.0-bifor :: (Bitraversable t, Applicative f)-      => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)-bifor t f g = bitraverse f g t---- | Alias for 'bifor'.------ @since 4.10.0.0-biforM :: (Bitraversable t, Applicative f)-       => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)-biforM = bifor---- | The 'bimapAccumL' function behaves like a combination of 'bimap' and--- 'bifoldl'; it traverses a structure from left to right, threading a state--- of type @a@ and using the given actions to compute new elements for the--- structure.------ ==== __Examples__------ Basic usage:------ >>> bimapAccumL (\acc bool -> (acc + 1, show bool)) (\acc string -> (acc * 2, reverse string)) 3 (True, "foo")--- (8,("True","oof"))------ @since 4.10.0.0-bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))-            -> a -> t b d -> (a, t c e)-bimapAccumL f g s t-  = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s---- | The 'bimapAccumR' function behaves like a combination of 'bimap' and--- 'bifoldr'; it traverses a structure from right to left, threading a state--- of type @a@ and using the given actions to compute new elements for the--- structure.------ ==== __Examples__------ Basic usage:------ >>> bimapAccumR (\acc bool -> (acc + 1, show bool)) (\acc string -> (acc * 2, reverse string)) 3 (True, "foo")--- (7,("True","oof"))------ @since 4.10.0.0-bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))-            -> a -> t b d -> (a, t c e)-bimapAccumR f g s t-  = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s---- | A default definition of 'bimap' in terms of the 'Bitraversable'--- operations.------ @'bimapDefault' f g ≡---     'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@------ @since 4.10.0.0-bimapDefault :: forall t a b c d . Bitraversable t-             => (a -> b) -> (c -> d) -> t a c -> t b d--- See Note [Function coercion] in Data.Functor.Utils.-bimapDefault = coerce-  (bitraverse :: (a -> Identity b)-              -> (c -> Identity d) -> t a c -> Identity (t b d))-{-# INLINE bimapDefault #-}---- | A default definition of 'bifoldMap' in terms of the 'Bitraversable'--- operations.------ @'bifoldMapDefault' f g ≡---    'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@------ @since 4.10.0.0-bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)-                 => (a -> m) -> (b -> m) -> t a b -> m--- See Note [Function coercion] in Data.Functor.Utils.-bifoldMapDefault = coerce-  (bitraverse :: (a -> Const m ())-              -> (b -> Const m ()) -> t a b -> Const m (t () ()))-{-# INLINE bifoldMapDefault #-}
− Data/Bits.hs 
@@ -1,208 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Bits--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ This module defines bitwise operations for signed and unsigned--- integers.  Instances of the class 'Bits' for the 'Int' and--- 'Integer' types are available from this module, and instances for--- explicitly sized integral types are available from the--- "Data.Int" and "Data.Word" modules.-----------------------------------------------------------------------------------module Data.Bits (-  -- * Type classes-  Bits(-    (.&.), (.|.), xor,-    complement,-    shift,-    rotate,-    zeroBits,-    bit,-    setBit,-    clearBit,-    complementBit,-    testBit,-    bitSizeMaybe,-    bitSize,-    isSigned,-    shiftL, shiftR,-    unsafeShiftL, unsafeShiftR,-    rotateL, rotateR,-    popCount-  ),-  FiniteBits(-    finiteBitSize,-    countLeadingZeros,-    countTrailingZeros-  ),-  -- * Extra functions-  bitDefault,-  testBitDefault,-  popCountDefault,-  toIntegralSized,-  oneBits,-  -- * Newtypes-  And(..), Ior(..), Xor(..), Iff(..)- ) where--import GHC.Base-import GHC.Bits-import GHC.Enum-import GHC.Read-import GHC.Show---- $setup--- >>> import Prelude--- >>> import Data.Word---- | A more concise version of @complement zeroBits@.------ >>> complement (zeroBits :: Word) == (oneBits :: Word)--- True------ >>> complement (oneBits :: Word) == (zeroBits :: Word)--- True------ = Note------ The constraint on 'oneBits' is arguably too strong. However, as some types--- (such as 'Natural') have undefined 'complement', this is the only safe--- choice.------ @since 4.16-oneBits :: (FiniteBits a) => a-oneBits = complement zeroBits-{-# INLINE oneBits #-}---- | Monoid under bitwise AND.------ >>> getAnd (And 0xab <> And 0x12) :: Word8--- 2------ @since 4.16-newtype And a = And { getAnd :: a }-  deriving newtype (-                    Bounded, -- ^ @since 4.16-                    Enum, -- ^ @since 4.16-                    Bits, -- ^ @since 4.16-                    FiniteBits, -- ^ @since 4.16-                    Eq -- ^ @since 4.16-                    )-  deriving stock (-                  Show, -- ^ @since 4.16-                  Read -- ^ @since 4.16-                 )---- | @since 4.16-instance (Bits a) => Semigroup (And a) where-  And x <> And y = And (x .&. y)---- | This constraint is arguably too strong. However,--- as some types (such as 'Natural') have undefined 'complement', this is the--- only safe choice.------ @since 4.16-instance (FiniteBits a) => Monoid (And a) where-  mempty = And oneBits---- | Monoid under bitwise inclusive OR.------ >>> getIor (Ior 0xab <> Ior 0x12) :: Word8--- 187------ @since 4.16-newtype Ior a = Ior { getIor :: a }-  deriving newtype (-                    Bounded, -- ^ @since 4.16-                    Enum, -- ^ @since 4.16-                    Bits, -- ^ @since 4.16-                    FiniteBits, -- ^ @since 4.16-                    Eq -- ^ @since 4.16-                    )-  deriving stock (-                  Show, -- ^ @since 4.16-                  Read -- ^ @since 4.16-                 )---- | @since 4.16-instance (Bits a) => Semigroup (Ior a) where-  Ior x <> Ior y = Ior (x .|. y)---- | @since 4.16-instance (Bits a) => Monoid (Ior a) where-  mempty = Ior zeroBits---- | Monoid under bitwise XOR.------ >>> getXor (Xor 0xab <> Xor 0x12) :: Word8--- 185------ @since 4.16-newtype Xor a = Xor { getXor :: a }-  deriving newtype (-                    Bounded, -- ^ @since 4.16-                    Enum, -- ^ @since 4.16-                    Bits, -- ^ @since 4.16-                    FiniteBits, -- ^ @since 4.16-                    Eq -- ^ @since 4.16-                    )-  deriving stock (-                  Show, -- ^ @since 4.16-                  Read -- ^ @since 4.16-                 )---- | @since 4.16-instance (Bits a) => Semigroup (Xor a) where-  Xor x <> Xor y = Xor (x `xor` y)---- | @since 4.16-instance (Bits a) => Monoid (Xor a) where-  mempty = Xor zeroBits---- | Monoid under bitwise \'equality\'; defined as @1@ if the corresponding--- bits match, and @0@ otherwise.------ >>> getIff (Iff 0xab <> Iff 0x12) :: Word8--- 70------ @since 4.16-newtype Iff a = Iff { getIff :: a }-  deriving newtype (-                    Bounded, -- ^ @since 4.16-                    Enum, -- ^ @since 4.16-                    Bits, -- ^ @since 4.16-                    FiniteBits, -- ^ @since 4.16-                    Eq -- ^ @since 4.16-                    )-  deriving stock (-                  Show, -- ^ @since 4.16-                  Read -- ^ @since 4.16-                 )---- | This constraint is arguably--- too strong. However, as some types (such as 'Natural') have undefined--- 'complement', this is the only safe choice.------ @since 4.16-instance (FiniteBits a) => Semigroup (Iff a) where-  Iff x <> Iff y = Iff . complement $ (x `xor` y)---- | This constraint is arguably--- too strong. However, as some types (such as 'Natural') have undefined--- 'complement', this is the only safe choice.------ @since 4.16-instance (FiniteBits a) => Monoid (Iff a) where-  mempty = Iff oneBits
− Data/Bool.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Bool--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ The 'Bool' type and related functions.-----------------------------------------------------------------------------------module Data.Bool (-   -- * Booleans-   Bool(..),-   -- ** Operations-   (&&),-   (||),-   not,-   otherwise,-   bool,-  ) where--import GHC.Base---- $setup--- >>> import Prelude---- | Case analysis for the 'Bool' type. @'bool' x y p@ evaluates to @x@--- when @p@ is 'False', and evaluates to @y@ when @p@ is 'True'.------ This is equivalent to @if p then y else x@; that is, one can--- think of it as an if-then-else construct with its arguments--- reordered.------ @since 4.7.0.0------ ==== __Examples__------ Basic usage:------ >>> bool "foo" "bar" True--- "bar"--- >>> bool "foo" "bar" False--- "foo"------ Confirm that @'bool' x y p@ and @if p then y else x@ are--- equivalent:------ >>> let p = True; x = "bar"; y = "foo"--- >>> bool x y p == if p then y else x--- True--- >>> let p = False--- >>> bool x y p == if p then y else x--- True----bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True  = t
− Data/Char.hs 
@@ -1,292 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Char--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ The Char type and associated operations.-----------------------------------------------------------------------------------module Data.Char-    (-      Char--    -- * Character classification-    -- | Unicode characters are divided into letters, numbers, marks,-    -- punctuation, symbols, separators (including spaces) and others-    -- (including control characters).-    , isControl, isSpace-    , isLower, isUpper, isAlpha, isAlphaNum, isPrint-    , isDigit, isOctDigit, isHexDigit-    , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator--    -- ** Subranges-    , isAscii, isLatin1-    , isAsciiUpper, isAsciiLower--    -- ** Unicode general categories-    , GeneralCategory(..), generalCategory--    -- * Case conversion-    , toUpper, toLower, toTitle--    -- * Single digit characters-    , digitToInt-    , intToDigit--    -- * Numeric representations-    , ord-    , chr--    -- * String representations-    , showLitChar-    , lexLitChar-    , readLitChar-    ) where--import GHC.Base-import GHC.Char-import GHC.Real (fromIntegral)-import GHC.Show-import GHC.Read (readLitChar, lexLitChar)-import GHC.Unicode-import GHC.Num---- $setup--- Allow the use of Prelude in doctests.--- >>> import Prelude---- | Convert a single digit 'Char' to the corresponding 'Int'.  This--- function fails unless its argument satisfies 'isHexDigit', but--- recognises both upper- and lower-case hexadecimal digits (that--- is, @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).------ ==== __Examples__------ Characters @\'0\'@ through @\'9\'@ are converted properly to--- @0..9@:------ >>> map digitToInt ['0'..'9']--- [0,1,2,3,4,5,6,7,8,9]------ Both upper- and lower-case @\'A\'@ through @\'F\'@ are converted--- as well, to @10..15@.------ >>> map digitToInt ['a'..'f']--- [10,11,12,13,14,15]--- >>> map digitToInt ['A'..'F']--- [10,11,12,13,14,15]------ Anything else throws an exception:------ >>> digitToInt 'G'--- *** Exception: Char.digitToInt: not a digit 'G'--- >>> digitToInt '♥'--- *** Exception: Char.digitToInt: not a digit '\9829'----digitToInt :: Char -> Int-digitToInt c-  | (fromIntegral dec::Word) <= 9 = dec-  | (fromIntegral hexl::Word) <= 5 = hexl + 10-  | (fromIntegral hexu::Word) <= 5 = hexu + 10-  | 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'---- derived character classifiers---- | Selects alphabetic Unicode characters (lower-case, upper-case and--- title-case letters, plus letters of caseless scripts and--- modifiers letters). This function is equivalent to--- 'Data.Char.isAlpha'.------ This function returns 'True' if its argument has one of the--- following 'GeneralCategory's, or 'False' otherwise:------ * 'UppercaseLetter'--- * 'LowercaseLetter'--- * 'TitlecaseLetter'--- * 'ModifierLetter'--- * 'OtherLetter'------ These classes are defined in the--- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,--- part of the Unicode standard. The same document defines what is--- and is not a \"Letter\".------ ==== __Examples__------ Basic usage:------ >>> isLetter 'a'--- True--- >>> isLetter 'A'--- True--- >>> isLetter 'λ'--- True--- >>> isLetter '0'--- False--- >>> isLetter '%'--- False--- >>> isLetter '♥'--- False--- >>> isLetter '\31'--- False------ Ensure that 'isLetter' and 'isAlpha' are equivalent.------ >>> let chars = [(chr 0)..]--- >>> let letters = map isLetter chars--- >>> let alphas = map isAlpha chars--- >>> letters == alphas--- True----isLetter :: Char -> Bool-isLetter c = case generalCategory c of-        UppercaseLetter         -> True-        LowercaseLetter         -> True-        TitlecaseLetter         -> True-        ModifierLetter          -> True-        OtherLetter             -> True-        _                       -> False---- | Selects Unicode mark characters, for example accents and the--- like, which combine with preceding characters.------ This function returns 'True' if its argument has one of the--- following 'GeneralCategory's, or 'False' otherwise:------ * 'NonSpacingMark'--- * 'SpacingCombiningMark'--- * 'EnclosingMark'------ These classes are defined in the--- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,--- part of the Unicode standard. The same document defines what is--- and is not a \"Mark\".------ ==== __Examples__------ Basic usage:------ >>> isMark 'a'--- False--- >>> isMark '0'--- False------ Combining marks such as accent characters usually need to follow--- another character before they become printable:------ >>> map isMark "ò"--- [False,True]------ Puns are not necessarily supported:------ >>> isMark '✓'--- False----isMark :: Char -> Bool-isMark c = case generalCategory c of-        NonSpacingMark          -> True-        SpacingCombiningMark    -> True-        EnclosingMark           -> True-        _                       -> False---- | Selects Unicode numeric characters, including digits from various--- scripts, Roman numerals, et cetera.------ This function returns 'True' if its argument has one of the--- following 'GeneralCategory's, or 'False' otherwise:------ * 'DecimalNumber'--- * 'LetterNumber'--- * 'OtherNumber'------ These classes are defined in the--- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,--- part of the Unicode standard. The same document defines what is--- and is not a \"Number\".------ ==== __Examples__------ Basic usage:------ >>> isNumber 'a'--- False--- >>> isNumber '%'--- False--- >>> isNumber '3'--- True------ ASCII @\'0\'@ through @\'9\'@ are all numbers:------ >>> and $ map isNumber ['0'..'9']--- True------ Unicode Roman numerals are \"numbers\" as well:------ >>> isNumber 'Ⅸ'--- True----isNumber :: Char -> Bool-isNumber c = case generalCategory c of-        DecimalNumber           -> True-        LetterNumber            -> True-        OtherNumber             -> True-        _                       -> False---- | Selects Unicode space and separator characters.------ This function returns 'True' if its argument has one of the--- following 'GeneralCategory's, or 'False' otherwise:------ * 'Space'--- * 'LineSeparator'--- * 'ParagraphSeparator'------ These classes are defined in the--- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,--- part of the Unicode standard. The same document defines what is--- and is not a \"Separator\".------ ==== __Examples__------ Basic usage:------ >>> isSeparator 'a'--- False--- >>> isSeparator '6'--- False--- >>> isSeparator ' '--- True------ Warning: newlines and tab characters are not considered--- separators.------ >>> isSeparator '\n'--- False--- >>> isSeparator '\t'--- False------ But some more exotic characters are (like HTML's @&nbsp;@):------ >>> isSeparator '\160'--- True----isSeparator :: Char -> Bool-isSeparator c = case generalCategory c of-        Space                   -> True-        LineSeparator           -> True-        ParagraphSeparator      -> True-        _                       -> False-
− Data/Coerce.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Coerce--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Safe coercions between data types.------ More in-depth information can be found on the--- <https://gitlab.haskell.org/ghc/ghc/wikis/roles Roles wiki page>------ @since 4.7.0.0--------------------------------------------------------------------------------module Data.Coerce-        ( -- * Safe coercions-          coerce, Coercible-        ) where-import GHC.Prim (coerce)-import GHC.Types (Coercible)---- The import of GHC.Base is for build ordering; see Notes in GHC.Base for--- more info.-import GHC.Base ()
− Data/Complex.hs 
@@ -1,274 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Complex--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Complex numbers.-----------------------------------------------------------------------------------module Data.Complex-        (-        -- * Rectangular form-          Complex((:+))--        , realPart-        , imagPart-        -- * Polar form-        , mkPolar-        , cis-        , polar-        , magnitude-        , phase-        -- * Conjugate-        , conjugate--        )  where--import GHC.Base (Applicative (..))-import GHC.Generics (Generic, Generic1)-import GHC.Float (Floating(..))-import Data.Data (Data)-import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf,-                alignment)-import Control.Monad.Fix (MonadFix(..))-import Control.Monad.Zip (MonadZip(..))--infix  6  :+---- -------------------------------------------------------------------------------- The Complex type---- | Complex numbers are an algebraic type.------ 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.------ Note that `Complex`'s instances inherit the deficiencies from the type--- parameter's. For example, @Complex Float@'s 'Ord' instance has similar--- problems to `Float`'s.-data Complex a-  = !a :+ !a    -- ^ forms a complex number from its real and imaginary-                -- rectangular components.-        deriving ( Eq          -- ^ @since 2.01-                 , Show        -- ^ @since 2.01-                 , Read        -- ^ @since 2.01-                 , Data        -- ^ @since 2.01-                 , Generic     -- ^ @since 4.9.0.0-                 , Generic1    -- ^ @since 4.9.0.0-                 , Functor     -- ^ @since 4.9.0.0-                 , Foldable    -- ^ @since 4.9.0.0-                 , Traversable -- ^ @since 4.9.0.0-                 )---- -------------------------------------------------------------------------------- Functions over Complex---- | Extracts the real part of a complex number.-realPart :: Complex a -> a-realPart (x :+ _) =  x---- | Extracts the imaginary part of a complex number.-imagPart :: Complex a -> a-imagPart (_ :+ y) =  y---- | The conjugate of a complex number.-{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}-conjugate        :: Num a => Complex a -> Complex a-conjugate (x:+y) =  x :+ (-y)---- | Form a complex number from polar components of magnitude and phase.-{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-}-mkPolar          :: Floating a => a -> a -> Complex a-mkPolar r theta  =  r * cos theta :+ r * sin theta---- | @'cis' t@ is a complex value with magnitude @1@--- and phase @t@ (modulo @2*'pi'@).-{-# SPECIALISE cis :: Double -> Complex Double #-}-cis              :: Floating a => a -> Complex a-cis theta        =  cos theta :+ sin theta---- | The function 'polar' takes a complex number and--- returns a (magnitude, phase) pair in canonical form:--- the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@;--- if the magnitude is zero, then so is the phase.-{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-}-polar            :: (RealFloat a) => Complex a -> (a,a)-polar z          =  (magnitude z, phase z)---- | The nonnegative magnitude of a complex number.-{-# SPECIALISE magnitude :: Complex Double -> Double #-}-magnitude :: (RealFloat a) => Complex a -> a-magnitude (x:+y) =  scaleFloat k-                     (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y)))-                    where k  = max (exponent x) (exponent y)-                          mk = - k-                          sqr z = z * z---- | The phase of a complex number, in the range @(-'pi', 'pi']@.--- If the magnitude is zero, then so is the phase.-{-# SPECIALISE phase :: Complex Double -> Double #-}-phase :: (RealFloat a) => Complex a -> a-phase (0 :+ 0)   = 0            -- SLPJ July 97 from John Peterson-phase (x:+y)     = atan2 y x----- -------------------------------------------------------------------------------- Instances of Complex---- | @since 2.01-instance  (RealFloat a) => Num (Complex a)  where-    {-# SPECIALISE instance Num (Complex Float) #-}-    {-# SPECIALISE instance Num (Complex Double) #-}-    (x:+y) + (x':+y')   =  (x+x') :+ (y+y')-    (x:+y) - (x':+y')   =  (x-x') :+ (y-y')-    (x:+y) * (x':+y')   =  (x*x'-y*y') :+ (x*y'+y*x')-    negate (x:+y)       =  negate x :+ negate y-    abs z               =  magnitude z :+ 0-    signum (0:+0)       =  0-    signum z@(x:+y)     =  x/r :+ y/r  where r = magnitude z-    fromInteger n       =  fromInteger n :+ 0---- | @since 2.01-instance  (RealFloat a) => Fractional (Complex a)  where-    {-# SPECIALISE instance Fractional (Complex Float) #-}-    {-# SPECIALISE instance Fractional (Complex Double) #-}-    (x:+y) / (x':+y')   =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d-                           where x'' = scaleFloat k x'-                                 y'' = scaleFloat k y'-                                 k   = - max (exponent x') (exponent y')-                                 d   = x'*x'' + y'*y''--    fromRational a      =  fromRational a :+ 0---- | @since 2.01-instance  (RealFloat a) => Floating (Complex a) where-    {-# SPECIALISE instance Floating (Complex Float) #-}-    {-# SPECIALISE instance Floating (Complex Double) #-}-    pi             =  pi :+ 0-    exp (x:+y)     =  expx * cos y :+ expx * sin y-                      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')-                            v'    = abs y / (u'*2)-                            u'    = sqrt ((magnitude z + abs x) / 2)--    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y-    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)-    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))-                      where sinx  = sin x-                            cosx  = cos x-                            sinhy = sinh y-                            coshy = cosh y--    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x-    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x-    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)-                      where siny  = sin y-                            cosy  = cos y-                            sinhx = sinh x-                            coshx = cosh x--    asin z@(x:+y)  =  y':+(-x')-                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))-    acos z         =  y'':+(-x'')-                      where (x'':+y'') = log (z + ((-y'):+x'))-                            (x':+y')   = sqrt (1 - z*z)-    atan z@(x:+y)  =  y':+(-x')-                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))--    asinh z        =  log (z + sqrt (1+z*z))-    -- Take care to allow (-1)::Complex, fixing #8532-    acosh z        =  log (z + (sqrt $ z+1) * (sqrt $ 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 #-}---- | @since 4.8.0.0-instance Storable a => Storable (Complex a) where-    sizeOf a       = 2 * sizeOf (realPart a)-    alignment a    = alignment (realPart a)-    peek p           = do-                        q <- return $ castPtr p-                        r <- peek q-                        i <- peekElemOff q 1-                        return (r :+ i)-    poke p (r :+ i)  = do-                        q <-return $  (castPtr p)-                        poke q r-                        pokeElemOff q 1 i---- | @since 4.9.0.0-instance Applicative Complex where-  pure a = a :+ a-  f :+ g <*> a :+ b = f a :+ g b-  liftA2 f (x :+ y) (a :+ b) = f x a :+ f y b---- | @since 4.9.0.0-instance Monad Complex where-  a :+ b >>= f = realPart (f a) :+ imagPart (f b)---- | @since 4.15.0.0-instance MonadZip Complex where-  mzipWith = liftA2---- | @since 4.15.0.0-instance MonadFix Complex where-  mfix f = (let a :+ _ = f a in a) :+ (let _ :+ a = f a in a)---- -------------------------------------------------------------------------------- Rules on Complex--{-# RULES--"realToFrac/a->Complex Double"-  realToFrac = \x -> realToFrac x :+ (0 :: Double)--"realToFrac/a->Complex Float"-  realToFrac = \x -> realToFrac x :+ (0 :: Float)--  #-}
− Data/Data.hs 
@@ -1,1366 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Data--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell.  See--- <http://www.haskell.org/haskellwiki/Research_papers/Generics#Scrap_your_boilerplate.21>.--- This module provides the 'Data' class with its primitives for--- generic programming, along with instances for many datatypes. It--- corresponds to a merge between the previous "Data.Generics.Basics"--- and almost all of "Data.Generics.Instances". The instances that are--- not present in this module were moved to the--- @Data.Generics.Instances@ module in the @syb@ package.------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.-----------------------------------------------------------------------------------module Data.Data (--        -- * Module Data.Typeable re-exported for convenience-        module Data.Typeable,--        -- * The Data class for processing constructor applications-        Data(-                gfoldl,-                gunfold,-                toConstr,-                dataTypeOf,-                dataCast1,      -- mediate types and unary type constructors-                dataCast2,      -- mediate types and binary type constructors-                -- Generic maps defined in terms of gfoldl-                gmapT,-                gmapQ,-                gmapQl,-                gmapQr,-                gmapQi,-                gmapM,-                gmapMp,-                gmapMo-            ),--        -- * Datatype representations-        DataType,       -- abstract-        -- ** Constructors-        mkDataType,-        mkIntType,-        mkFloatType,-        mkCharType,-        mkNoRepType,-        -- ** Observers-        dataTypeName,-        DataRep(..),-        dataTypeRep,-        -- ** Convenience functions-        repConstr,-        isAlgType,-        dataTypeConstrs,-        indexConstr,-        maxConstrIndex,-        isNorepType,--        -- * Data constructor representations-        Constr,         -- abstract-        ConIndex,       -- alias for Int, start at 1-        Fixity(..),-        -- ** Constructors-        mkConstr,-        mkConstrTag,-        mkIntegralConstr,-        mkRealConstr,-        mkCharConstr,-        -- ** Observers-        constrType,-        ConstrRep(..),-        constrRep,-        constrFields,-        constrFixity,-        -- ** Convenience function: algebraic data types-        constrIndex,-        -- ** From strings to constructors and vice versa: all data types-        showConstr,-        readConstr,--        -- * Convenience functions: take type constructors apart-        tyconUQname,-        tyconModule,--        -- * Generic operations defined in terms of 'gunfold'-        fromConstr,-        fromConstrB,-        fromConstrM--  ) where-----------------------------------------------------------------------------------import Data.Functor.Const-import Data.Either-import Data.Eq-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.List (findIndex)-import Data.Typeable-import Data.Version( Version(..) )-import GHC.Base hiding (Any, IntRep, FloatRep)-import GHC.List-import GHC.Num-import GHC.Read-import GHC.Show-import GHC.Tuple (Solo (..))-import Text.Read( reads )---- Imports for the instances-import Control.Applicative (WrappedArrow(..), WrappedMonad(..), ZipList(..))-       -- So we can give them Data instances-import Data.Functor.Identity -- So we can give Data instance for Identity-import Data.Int              -- So we can give Data instance for Int8, ...-import Data.Type.Coercion-import Data.Word             -- So we can give Data instance for Word8, ...-import GHC.Real              -- So we can give Data instance for Ratio---import GHC.IOBase            -- So we can give Data instance for IO, Handle-import GHC.Ptr               -- So we can give Data instance for Ptr-import GHC.ForeignPtr        -- So we can give Data instance for ForeignPtr-import Foreign.Ptr (IntPtr(..), WordPtr(..))-                             -- So we can give Data instance for IntPtr and WordPtr---import GHC.Stable            -- So we can give Data instance for StablePtr---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, ...--------------------------------------------------------------------------------------      The Data class------------------------------------------------------------------------------------{- |-The 'Data' class comprehends a fundamental primitive 'gfoldl' for-folding over constructor applications, say terms. This primitive can-be instantiated in several ways to map over the immediate subterms-of a term; see the @gmap@ combinators later in this class.  Indeed, a-generic programmer does not necessarily need to use the ingenious gfoldl-primitive but rather the intuitive @gmap@ combinators.  The 'gfoldl'-primitive is completed by means to query top-level constructors, to-turn constructor representations into proper terms, and to list all-possible datatype constructors.  This completion allows us to serve-generic programming scenarios like read, show, equality, term generation.--The combinators 'gmapT', 'gmapQ', 'gmapM', etc are all provided with-default definitions in terms of 'gfoldl', leaving open the opportunity-to provide datatype-specific definitions.-(The inclusion of the @gmap@ combinators as members of class 'Data'-allows the programmer or the compiler to derive specialised, and maybe-more efficient code per datatype.  /Note/: 'gfoldl' is more higher-order-than the @gmap@ combinators.  This is subject to ongoing benchmarking-experiments.  It might turn out that the @gmap@ combinators will be-moved out of the class 'Data'.)--Conceptually, the definition of the @gmap@ combinators in terms of the-primitive 'gfoldl' requires the identification of the 'gfoldl' function-arguments.  Technically, we also need to identify the type constructor-@c@ for the construction of the result type from the folded term type.--In the definition of @gmapQ@/x/ combinators, we use phantom type-constructors for the @c@ in the type of 'gfoldl' because the result type-of a query does not involve the (polymorphic) type of the term argument.-In the definition of 'gmapQl' we simply use the plain constant type-constructor because 'gfoldl' is left-associative anyway and so it is-readily suited to fold a left-associative binary operation over the-immediate subterms.  In the definition of gmapQr, extra effort is-needed. We use a higher-order accumulation trick to mediate between-left-associative constructor application vs. right-associative binary-operation (e.g., @(:)@).  When the query is meant to compute a value-of type @r@, then the result type within generic folding is @r -> r@.-So the result of folding is a function to which we finally pass the-right unit.--With the @-XDeriveDataTypeable@ option, GHC can generate instances of the-'Data' class automatically.  For example, given the declaration--> data T a b = C1 a b | C2 deriving (Typeable, Data)--GHC will generate an instance that is equivalent to--> instance (Data a, Data b) => Data (T a b) where->     gfoldl k z (C1 a b) = z C1 `k` a `k` b->     gfoldl k z C2       = z C2->->     gunfold k z c = case constrIndex c of->                         1 -> k (k (z C1))->                         2 -> z C2->->     toConstr (C1 _ _) = con_C1->     toConstr C2       = con_C2->->     dataTypeOf _ = ty_T->-> con_C1 = mkConstr ty_T "C1" [] Prefix-> con_C2 = mkConstr ty_T "C2" [] Prefix-> ty_T   = mkDataType "Module.T" [con_C1, con_C2]--This is suitable for datatypes that are exported transparently.---}--class Typeable a => Data a where--  -- | Left-associative fold operation for constructor applications.-  ---  -- The type of 'gfoldl' is a headache, but operationally it is a simple-  -- generalisation of a list fold.-  ---  -- The default definition for 'gfoldl' is @'const' 'id'@, which is-  -- suitable for abstract datatypes with no substructures.-  gfoldl  :: (forall d b. Data d => c (d -> b) -> d -> c b)-                -- ^ defines how nonempty constructor applications are-                -- folded.  It takes the folded tail of the constructor-                -- application and its head, i.e., an immediate subterm,-                -- and combines them in some way.-          -> (forall g. g -> c g)-                -- ^ defines how the empty constructor application is-                -- folded, like the neutral \/ start element for list-                -- folding.-          -> a-                -- ^ structure to be folded.-          -> c a-                -- ^ result, with a type defined in terms of @a@, but-                -- variability is achieved by means of type constructor-                -- @c@ for the construction of the actual result type.--  -- See the 'Data' instances in this file for an illustration of 'gfoldl'.--  gfoldl _ z = z--  -- | Unfolding constructor applications-  gunfold :: (forall b r. Data b => c (b -> r) -> c r)-          -> (forall r. r -> c r)-          -> Constr-          -> c a--  -- | Obtaining the constructor from a given datum.-  -- For proper terms, this is meant to be the top-level constructor.-  -- Primitive datatypes are here viewed as potentially infinite sets of-  -- values (i.e., constructors).-  toConstr   :: a -> Constr---  -- | The outer type constructor of the type-  dataTypeOf  :: a -> DataType---------------------------------------------------------------------------------------- Mediate types and type constructors------------------------------------------------------------------------------------  -- | Mediate types and unary type constructors.-  ---  -- In 'Data' instances of the form-  ---  -- @-  --     instance (Data a, ...) => Data (T a)-  -- @-  ---  -- 'dataCast1' should be defined as 'gcast1'.-  ---  -- The default definition is @'const' 'Nothing'@, which is appropriate-  -- for instances of other forms.-  dataCast1 :: Typeable t-            => (forall d. Data d => c (t d))-            -> Maybe (c a)-  dataCast1 _ = Nothing--  -- | Mediate types and binary type constructors.-  ---  -- In 'Data' instances of the form-  ---  -- @-  --     instance (Data a, Data b, ...) => Data (T a b)-  -- @-  ---  -- 'dataCast2' should be defined as 'gcast2'.-  ---  -- The default definition is @'const' 'Nothing'@, which is appropriate-  -- for instances of other forms.-  dataCast2 :: Typeable t-            => (forall d e. (Data d, Data e) => c (t d e))-            -> Maybe (c a)-  dataCast2 _ = Nothing----------------------------------------------------------------------------------------      Typical generic maps defined in terms of gfoldl-------------------------------------------------------------------------------------  -- | A generic transformation that maps over the immediate subterms-  ---  -- The default definition instantiates the type constructor @c@ in the-  -- type of 'gfoldl' to an identity datatype constructor, using the-  -- isomorphism pair as injection and projection.-  gmapT :: (forall b. Data b => b -> b) -> a -> a--  -- Use the Identity datatype constructor-  -- to instantiate the type constructor c in the type of gfoldl,-  -- and perform injections Identity and projections runIdentity accordingly.-  ---  gmapT f x0 = runIdentity (gfoldl k Identity x0)-    where-      k :: Data d => Identity (d->b) -> d -> Identity b-      k (Identity c) x = Identity (c (f x))---  -- | A generic query with a left-associative binary operator-  gmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r-  gmapQl o r f = getConst . gfoldl k z-    where-      k :: Data d => Const r (d->b) -> d -> Const r b-      k c x = Const $ (getConst c) `o` f x-      z :: g -> Const r g-      z _   = Const r--  -- | A generic query with a right-associative binary operator-  gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r-  gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0-    where-      k :: Data d => Qr r (d->b) -> d -> Qr r b-      k (Qr c) x = Qr (\r -> c (f x `o` r))---  -- | A generic query that processes the immediate subterms and returns a list-  -- of results.  The list is given in the same order as originally specified-  -- in the declaration of the data constructors.-  gmapQ :: (forall d. Data d => d -> u) -> a -> [u]-  gmapQ f = gmapQr (:) [] f---  -- | A generic query that processes one child by index (zero-based)-  gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> a -> u-  gmapQi i f x = case gfoldl k z x of { Qi _ q -> fromJust q }-    where-      k :: Data d => Qi u (d -> b) -> d -> Qi u b-      k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q)-      z :: g -> Qi q g-      z _           = Qi 0 Nothing---  -- | A generic monadic transformation that maps over the immediate subterms-  ---  -- The default definition instantiates the type constructor @c@ in-  -- the type of 'gfoldl' to the monad datatype constructor, defining-  -- injection and projection using 'return' and '>>='.-  gmapM :: forall m. Monad m => (forall d. Data d => d -> m d) -> a -> m a--  -- Use immediately the monad datatype constructor-  -- to instantiate the type constructor c in the type of gfoldl,-  -- so injection and projection is done by return and >>=.-  ---  gmapM f = gfoldl k return-    where-      k :: Data d => m (d -> b) -> d -> m b-      k c x = do c' <- c-                 x' <- f x-                 return (c' x')---  -- | Transformation of at least one immediate subterm does not fail-  gmapMp :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a--{---The type constructor that we use here simply keeps track of the fact-if we already succeeded for an immediate subterm; see Mp below. To-this end, we couple the monadic computation with a Boolean.---}--  gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) ->-                if b then return x' else mzero-    where-      z :: g -> Mp m g-      z g = Mp (return (g,False))-      k :: Data d => Mp m (d -> b) -> d -> Mp m b-      k (Mp c) y-        = Mp ( c >>= \(h, b) ->-                 (f y >>= \y' -> return (h y', True))-                 `mplus` return (h y, b)-             )--  -- | Transformation of one immediate subterm with success-  gmapMo :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a--{---We use the same pairing trick as for gmapMp,-i.e., we use an extra Bool component to keep track of the-fact whether an immediate subterm was processed successfully.-However, we cut of mapping over subterms once a first subterm-was transformed successfully.---}--  gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) ->-                if b then return x' else mzero-    where-      z :: g -> Mp m g-      z g = Mp (return (g,False))-      k :: Data d => Mp m (d -> b) -> d -> Mp m b-      k (Mp c) y-        = Mp ( c >>= \(h,b) -> if b-                        then return (h y, b)-                        else (f y >>= \y' -> return (h y',True))-                             `mplus` return (h y, b)-             )----- | Type constructor for adding counters to queries-data Qi q a = Qi Int (Maybe q)----- | The type constructor used in definition of gmapQr-newtype Qr r a = Qr { unQr  :: r -> r }----- | The type constructor used in definition of gmapMp-newtype Mp m x = Mp { unMp :: m (x, Bool) }----------------------------------------------------------------------------------------      Generic unfolding--------------------------------------------------------------------------------------- | Build a term skeleton-fromConstr :: Data a => Constr -> a-fromConstr = fromConstrB (errorWithoutStackTrace "Data.Data.fromConstr")----- | Build a term and use a generic function for subterms-fromConstrB :: Data a-            => (forall d. Data d => d)-            -> Constr-            -> a-fromConstrB f = runIdentity . gunfold k z- where-  k :: forall b r. Data b => Identity (b -> r) -> Identity r-  k c = Identity (runIdentity c f)--  z :: forall r. r -> Identity r-  z = Identity----- | Monadic variation on 'fromConstrB'-fromConstrM :: forall m a. (Monad m, Data a)-            => (forall d. Data d => m d)-            -> Constr-            -> m a-fromConstrM f = gunfold k z- where-  k :: forall b r. Data b => m (b -> r) -> m r-  k c = do { c' <- c; b <- f; return (c' b) }--  z :: forall r. r -> m r-  z = return----------------------------------------------------------------------------------------      Datatype and constructor representations------------------------------------------------------------------------------------------ | Representation of datatypes.--- A package of constructor representations with names of type and module.----data DataType = DataType-                        { tycon   :: String-                        , datarep :: DataRep-                        }--              deriving Show -- ^ @since 4.0.0.0---- | Representation of constructors. Note that equality on constructors--- with different types may not work -- i.e. the constructors for 'False' and--- 'Nothing' may compare equal.-data Constr = Constr-                        { conrep    :: ConstrRep-                        , constring :: String-                        , confields :: [String] -- for AlgRep only-                        , confixity :: Fixity   -- for AlgRep only-                        , datatype  :: DataType-                        }---- | @since 4.0.0.0-instance Show Constr where- show = constring----- | Equality of constructors------ @since 4.0.0.0-instance Eq Constr where-  c == c' = constrRep c == constrRep c'----- | Public representation of datatypes-data DataRep = AlgRep [Constr]-             | IntRep-             | FloatRep-             | CharRep-             | NoRep--            deriving ( Eq   -- ^ @since 4.0.0.0-                     , Show -- ^ @since 4.0.0.0-                     )--- The list of constructors could be an array, a balanced tree, or others.----- | Public representation of constructors-data ConstrRep = AlgConstr    ConIndex-               | IntConstr    Integer-               | FloatConstr  Rational-               | CharConstr   Char--               deriving ( Eq   -- ^ @since 4.0.0.0-                        , Show -- ^ @since 4.0.0.0-                        )----- | Unique index for datatype constructors,--- counting from 1 in the order they are given in the program text.-type ConIndex = Int----- | Fixity of constructors-data Fixity = Prefix-            | Infix     -- Later: add associativity and precedence--            deriving ( Eq   -- ^ @since 4.0.0.0-                     , Show -- ^ @since 4.0.0.0-                     )---------------------------------------------------------------------------------------      Observers for datatype representations--------------------------------------------------------------------------------------- | Gets the type constructor including the module-dataTypeName :: DataType -> String-dataTypeName = tycon------ | Gets the public presentation of a datatype-dataTypeRep :: DataType -> DataRep-dataTypeRep = datarep----- | Gets the datatype of a constructor-constrType :: Constr -> DataType-constrType = datatype----- | Gets the public presentation of constructors-constrRep :: Constr -> ConstrRep-constrRep = conrep----- | Look up a constructor by its representation-repConstr :: DataType -> ConstrRep -> Constr-repConstr dt cr =-      case (dataTypeRep dt, cr) of-        (AlgRep cs, AlgConstr i)      -> cs !! (i-1)-        (IntRep,    IntConstr i)      -> mkIntegralConstr dt i-        (FloatRep,  FloatConstr f)    -> mkRealConstr dt f-        (CharRep,   CharConstr c)     -> mkCharConstr dt c-        _ -> errorWithoutStackTrace "Data.Data.repConstr: The given ConstrRep does not fit to the given DataType."----------------------------------------------------------------------------------------      Representations of algebraic data types--------------------------------------------------------------------------------------- | Constructs an algebraic datatype-mkDataType :: String -> [Constr] -> DataType-mkDataType str cs = DataType-                        { tycon   = str-                        , datarep = AlgRep cs-                        }---- | Constructs a constructor-mkConstrTag :: DataType -> String -> Int -> [String] -> Fixity -> Constr-mkConstrTag dt str idx fields fix =-        Constr-                { conrep    = AlgConstr idx-                , constring = str-                , confields = fields-                , confixity = fix-                , datatype  = dt-                }---- | Constructs a constructor-mkConstr :: DataType -> String -> [String] -> Fixity -> Constr-mkConstr dt str fields fix = mkConstrTag dt str idx fields fix-  where-    idx = case findIndex (\c -> showConstr c == str) (dataTypeConstrs dt) of-            Just i  -> i+1 -- ConTag starts at 1-            Nothing -> errorWithoutStackTrace $-                        "Data.Data.mkConstr: couldn't find constructor " ++ str----- | Gets the constructors of an algebraic datatype-dataTypeConstrs :: DataType -> [Constr]-dataTypeConstrs dt = case datarep dt of-                        (AlgRep cons) -> cons-                        _ -> errorWithoutStackTrace $ "Data.Data.dataTypeConstrs is not supported for "-                                    ++ dataTypeName dt ++-                                    ", as it is not an algebraic data type."----- | Gets the field labels of a constructor.  The list of labels--- is returned in the same order as they were given in the original--- constructor declaration.-constrFields :: Constr -> [String]-constrFields = confields----- | Gets the fixity of a constructor-constrFixity :: Constr -> Fixity-constrFixity = confixity----------------------------------------------------------------------------------------      From strings to constr's and vice versa: all data types--------------------------------------------------------------------------------------- | Gets the string for a constructor-showConstr :: Constr -> String-showConstr = constring----- | Lookup a constructor via a string-readConstr :: DataType -> String -> Maybe Constr-readConstr dt str =-      case dataTypeRep dt of-        AlgRep cons -> idx cons-        IntRep      -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))-        FloatRep    -> mkReadCon ffloat-        CharRep     -> mkReadCon (\c -> (mkPrimCon dt str (CharConstr c)))-        NoRep       -> Nothing-  where--    -- Read a value and build a constructor-    mkReadCon :: Read t => (t -> Constr) -> Maybe Constr-    mkReadCon f = case (reads str) of-                    [(t,"")] -> Just (f t)-                    _ -> Nothing--    -- Traverse list of algebraic datatype constructors-    idx :: [Constr] -> Maybe Constr-    idx cons = let fit = filter ((==) str . showConstr) cons-                in if fit == []-                     then Nothing-                     else Just (head fit)--    ffloat :: Double -> Constr-    ffloat =  mkPrimCon dt str . FloatConstr . toRational--------------------------------------------------------------------------------------      Convenience functions: algebraic data types--------------------------------------------------------------------------------------- | Test for an algebraic type-isAlgType :: DataType -> Bool-isAlgType dt = case datarep dt of-                 (AlgRep _) -> True-                 _ -> False----- | Gets the constructor for an index (algebraic datatypes only)-indexConstr :: DataType -> ConIndex -> Constr-indexConstr dt idx = case datarep dt of-                        (AlgRep cs) -> cs !! (idx-1)-                        _           -> errorWithoutStackTrace $ "Data.Data.indexConstr is not supported for "-                                               ++ dataTypeName dt ++-                                               ", as it is not an algebraic data type."----- | Gets the index of a constructor (algebraic datatypes only)-constrIndex :: Constr -> ConIndex-constrIndex con = case constrRep con of-                    (AlgConstr idx) -> idx-                    _ -> errorWithoutStackTrace $ "Data.Data.constrIndex is not supported for "-                                 ++ dataTypeName (constrType con) ++-                                 ", as it is not an algebraic data type."----- | Gets the maximum constructor index of an algebraic datatype-maxConstrIndex :: DataType -> ConIndex-maxConstrIndex dt = case dataTypeRep dt of-                        AlgRep cs -> length cs-                        _            -> errorWithoutStackTrace $ "Data.Data.maxConstrIndex is not supported for "-                                                 ++ dataTypeName dt ++-                                                 ", as it is not an algebraic data type."----------------------------------------------------------------------------------------      Representation of primitive types--------------------------------------------------------------------------------------- | Constructs the 'Int' type-mkIntType :: String -> DataType-mkIntType = mkPrimType IntRep----- | Constructs the 'Float' type-mkFloatType :: String -> DataType-mkFloatType = mkPrimType FloatRep----- | Constructs the 'Char' type-mkCharType :: String -> DataType-mkCharType = mkPrimType CharRep----- | Helper for 'mkIntType', 'mkFloatType'-mkPrimType :: DataRep -> String -> DataType-mkPrimType dr str = DataType-                        { tycon   = str-                        , datarep = dr-                        }----- Makes a constructor for primitive types-mkPrimCon :: DataType -> String -> ConstrRep -> Constr-mkPrimCon dt str cr = Constr-                        { datatype  = dt-                        , conrep    = cr-                        , constring = str-                        , 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))-                  _ -> 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))-                    _ -> errorWithoutStackTrace $ "Data.Data.mkRealConstr is not supported for "-                                 ++ dataTypeName dt ++-                                 ", as it is not a Real data type."---- | Makes a constructor for 'Char'.-mkCharConstr :: DataType -> Char -> Constr-mkCharConstr dt c = case datarep dt of-                   CharRep -> mkPrimCon dt (show c) (CharConstr c)-                   _ -> errorWithoutStackTrace $ "Data.Data.mkCharConstr is not supported for "-                                ++ dataTypeName dt ++-                                ", as it is not an Char data type."---------------------------------------------------------------------------------------      Non-representations for non-representable types--------------------------------------------------------------------------------------- | Constructs a non-representation for a non-representable type-mkNoRepType :: String -> DataType-mkNoRepType str = DataType-                        { tycon   = str-                        , datarep = NoRep-                        }---- | Test for a non-representable type-isNorepType :: DataType -> Bool-isNorepType dt = case datarep dt of-                   NoRep -> True-                   _ -> False----------------------------------------------------------------------------------------      Convenience for qualified type constructors--------------------------------------------------------------------------------------- | Gets the unqualified type constructor:--- drop *.*.*... before name----tyconUQname :: String -> String-tyconUQname x = let x' = dropWhile (not . (==) '.') x-                 in if x' == [] then x else tyconUQname (tail x')----- | Gets the module of a type constructor:--- take *.*.*... before name-tyconModule :: String -> String-tyconModule x = let (a,b) = break ((==) '.') x-                 in if b == ""-                      then b-                      else a ++ tyconModule' (tail b)-  where-    tyconModule' y = let y' = tyconModule y-                      in if y' == "" then "" else ('.':y')------------------------------------------------------------------------------------------------------------------------------------------------------------------------      Instances of the Data class for Prelude-like types.---      We define top-level definitions for representations.-------------------------------------------------------------------------------------- | @since 4.0.0.0-deriving instance Data Bool----------------------------------------------------------------------------------charType :: DataType-charType = mkCharType "Prelude.Char"---- | @since 4.0.0.0-instance Data Char where-  toConstr x = mkCharConstr charType x-  gunfold _ z c = case constrRep c of-                    (CharConstr x) -> z x-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Char."-  dataTypeOf _ = charType-----------------------------------------------------------------------------------floatType :: DataType-floatType = mkFloatType "Prelude.Float"---- | @since 4.0.0.0-instance Data Float where-  toConstr = mkRealConstr floatType-  gunfold _ z c = case constrRep c of-                    (FloatConstr x) -> z (realToFrac x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Float."-  dataTypeOf _ = floatType-----------------------------------------------------------------------------------doubleType :: DataType-doubleType = mkFloatType "Prelude.Double"---- | @since 4.0.0.0-instance Data Double where-  toConstr = mkRealConstr doubleType-  gunfold _ z c = case constrRep c of-                    (FloatConstr x) -> z (realToFrac x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Double."-  dataTypeOf _ = doubleType-----------------------------------------------------------------------------------intType :: DataType-intType = mkIntType "Prelude.Int"---- | @since 4.0.0.0-instance Data Int where-  toConstr x = mkIntegralConstr intType x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Int."-  dataTypeOf _ = intType-----------------------------------------------------------------------------------integerType :: DataType-integerType = mkIntType "Prelude.Integer"---- | @since 4.0.0.0-instance Data Integer where-  toConstr = mkIntegralConstr integerType-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z x-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Integer."-  dataTypeOf _ = integerType------------------------------------------------------------------------------------- This follows the same style as the other integral 'Data' instances--- defined in "Data.Data"-naturalType :: DataType-naturalType = mkIntType "Numeric.Natural.Natural"---- | @since 4.8.0.0-instance Data Natural where-  toConstr x = mkIntegralConstr naturalType x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Natural"-  dataTypeOf _ = naturalType-----------------------------------------------------------------------------------int8Type :: DataType-int8Type = mkIntType "Data.Int.Int8"---- | @since 4.0.0.0-instance Data Int8 where-  toConstr x = mkIntegralConstr int8Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Int8."-  dataTypeOf _ = int8Type-----------------------------------------------------------------------------------int16Type :: DataType-int16Type = mkIntType "Data.Int.Int16"---- | @since 4.0.0.0-instance Data Int16 where-  toConstr x = mkIntegralConstr int16Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Int16."-  dataTypeOf _ = int16Type-----------------------------------------------------------------------------------int32Type :: DataType-int32Type = mkIntType "Data.Int.Int32"---- | @since 4.0.0.0-instance Data Int32 where-  toConstr x = mkIntegralConstr int32Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Int32."-  dataTypeOf _ = int32Type-----------------------------------------------------------------------------------int64Type :: DataType-int64Type = mkIntType "Data.Int.Int64"---- | @since 4.0.0.0-instance Data Int64 where-  toConstr x = mkIntegralConstr int64Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Int64."-  dataTypeOf _ = int64Type-----------------------------------------------------------------------------------wordType :: DataType-wordType = mkIntType "Data.Word.Word"---- | @since 4.0.0.0-instance Data Word where-  toConstr x = mkIntegralConstr wordType x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Word"-  dataTypeOf _ = wordType-----------------------------------------------------------------------------------word8Type :: DataType-word8Type = mkIntType "Data.Word.Word8"---- | @since 4.0.0.0-instance Data Word8 where-  toConstr x = mkIntegralConstr word8Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Word8."-  dataTypeOf _ = word8Type-----------------------------------------------------------------------------------word16Type :: DataType-word16Type = mkIntType "Data.Word.Word16"---- | @since 4.0.0.0-instance Data Word16 where-  toConstr x = mkIntegralConstr word16Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Word16."-  dataTypeOf _ = word16Type-----------------------------------------------------------------------------------word32Type :: DataType-word32Type = mkIntType "Data.Word.Word32"---- | @since 4.0.0.0-instance Data Word32 where-  toConstr x = mkIntegralConstr word32Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Word32."-  dataTypeOf _ = word32Type-----------------------------------------------------------------------------------word64Type :: DataType-word64Type = mkIntType "Data.Word.Word64"---- | @since 4.0.0.0-instance Data Word64 where-  toConstr x = mkIntegralConstr word64Type x-  gunfold _ z c = case constrRep c of-                    (IntConstr x) -> z (fromIntegral x)-                    _ -> errorWithoutStackTrace $ "Data.Data.gunfold: Constructor " ++ show c-                                 ++ " is not of type Word64."-  dataTypeOf _ = word64Type-----------------------------------------------------------------------------------ratioConstr :: Constr-ratioConstr = mkConstr ratioDataType ":%" [] Infix--ratioDataType :: DataType-ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr]---- NB: This Data instance intentionally uses the (%) smart constructor instead--- of the internal (:%) constructor to preserve the invariant that a Ratio--- value is reduced to normal form. See #10011.---- | @since 4.0.0.0-instance (Data a, Integral a) => Data (Ratio a) where-  gfoldl k z (a :% b) = z (%) `k` a `k` b-  toConstr _ = ratioConstr-  gunfold k z c | constrIndex c == 1 = k (k (z (%)))-  gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(Ratio)"-  dataTypeOf _  = ratioDataType-----------------------------------------------------------------------------------nilConstr :: Constr-nilConstr    = mkConstr listDataType "[]" [] Prefix-consConstr :: Constr-consConstr   = mkConstr listDataType "(:)" [] Infix--listDataType :: DataType-listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]---- | @since 4.0.0.0-instance Data a => Data [a] where-  gfoldl _ z []     = z []-  gfoldl f z (x:xs) = z (:) `f` x `f` xs-  toConstr []    = nilConstr-  toConstr (_:_) = consConstr-  gunfold k z c = case constrIndex c of-                    1 -> z []-                    2 -> k (k (z (:)))-                    _ -> errorWithoutStackTrace "Data.Data.gunfold(List)"-  dataTypeOf _ = listDataType-  dataCast1 f  = gcast1 f------- The gmaps are given as an illustration.--- This shows that the gmaps for lists are different from list maps.----  gmapT  _   []     = []-  gmapT  f   (x:xs) = (f x:f xs)-  gmapQ  _   []     = []-  gmapQ  f   (x:xs) = [f x,f xs]-  gmapM  _   []     = return []-  gmapM  f   (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')------------------------------------------------------------------------------------- | @since 4.14.0.0-deriving instance (Typeable (a :: Type -> Type -> Type), Typeable b, Typeable c,-                   Data (a b c))-         => Data (WrappedArrow a b c)---- | @since 4.14.0.0-deriving instance (Typeable (m :: Type -> Type), Typeable a, Data (m a))-         => Data (WrappedMonad m a)---- | @since 4.14.0.0-deriving instance Data a => Data (ZipList a)---- | @since 4.9.0.0-deriving instance Data a => Data (NonEmpty a)---- | @since 4.0.0.0-deriving instance Data a => Data (Maybe a)---- | @since 4.0.0.0-deriving instance Data Ordering---- | @since 4.0.0.0-deriving instance (Data a, Data b) => Data (Either a b)---- | @since 4.0.0.0-deriving instance Data ()---- | @since 4.15-deriving instance Data a => Data (Solo a)---- | @since 4.0.0.0-deriving instance (Data a, Data b) => Data (a,b)---- | @since 4.0.0.0-deriving instance (Data a, Data b, Data c) => Data (a,b,c)---- | @since 4.0.0.0-deriving instance (Data a, Data b, Data c, Data d)-         => Data (a,b,c,d)---- | @since 4.0.0.0-deriving instance (Data a, Data b, Data c, Data d, Data e)-         => Data (a,b,c,d,e)---- | @since 4.0.0.0-deriving instance (Data a, Data b, Data c, Data d, Data e, Data f)-         => Data (a,b,c,d,e,f)---- | @since 4.0.0.0-deriving instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g)-         => Data (a,b,c,d,e,f,g)------------------------------------------------------------------------------------ | @since 4.8.0.0-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------------------------------------------------------------------------------------ | @since 4.8.0.0-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---- | @since 4.11.0.0-deriving instance Data IntPtr---- | @since 4.11.0.0-deriving instance Data WordPtr----------------------------------------------------------------------------------- The Data instance for Array preserves data abstraction at the cost of--- inefficiency. We omit reflection services for the sake of data abstraction.--- | @since 4.8.0.0-instance (Data a, Data b, Ix a) => Data (Array a b)- where-  gfoldl f z a = z (listArray (bounds a)) `f` (elems a)-  toConstr _   = errorWithoutStackTrace "Data.Data.toConstr(Array)"-  gunfold _ _  = errorWithoutStackTrace "Data.Data.gunfold(Array)"-  dataTypeOf _ = mkNoRepType "Data.Array.Array"-  dataCast2 x  = gcast2 x--------------------------------------------------------------------------------- Data instance for Proxy---- | @since 4.7.0.0-deriving instance (Data t) => Data (Proxy t)---- | @since 4.7.0.0-deriving instance (a ~ b, Data a) => Data (a :~: b)---- | @since 4.10.0.0-deriving instance (Typeable i, Typeable j, Typeable a, Typeable b,-                    (a :: i) ~~ (b :: j))-    => Data (a :~~: b)---- | @since 4.7.0.0-deriving instance (Coercible a b, Data a, Data b) => Data (Coercion a b)---- | @since 4.9.0.0-deriving instance Data a => Data (Identity a)---- | @since 4.10.0.0-deriving instance (Typeable k, Data a, Typeable (b :: k)) => Data (Const a b)---- | @since 4.7.0.0-deriving instance Data Version--------------------------------------------------------------------------------- Data instances for Data.Monoid wrappers---- | @since 4.8.0.0-deriving instance Data a => Data (Dual a)---- | @since 4.8.0.0-deriving instance Data All---- | @since 4.8.0.0-deriving instance Data Any---- | @since 4.8.0.0-deriving instance Data a => Data (Sum a)---- | @since 4.8.0.0-deriving instance Data a => Data (Product a)---- | @since 4.8.0.0-deriving instance Data a => Data (First a)---- | @since 4.8.0.0-deriving instance Data a => Data (Last a)---- | @since 4.8.0.0-deriving instance (Data (f a), Data a, Typeable f) => Data (Alt f a)---- | @since 4.12.0.0-deriving instance (Data (f a), Data a, Typeable f) => Data (Ap f a)--------------------------------------------------------------------------------- Data instances for GHC.Generics representations---- | @since 4.9.0.0-deriving instance Data p => Data (U1 p)---- | @since 4.9.0.0-deriving instance Data p => Data (Par1 p)---- | @since 4.9.0.0-deriving instance (Data (f p), Typeable f, Data p) => Data (Rec1 f p)---- | @since 4.9.0.0-deriving instance (Typeable i, Data p, Data c) => Data (K1 i c p)---- | @since 4.9.0.0-deriving instance (Data p, Data (f p), Typeable c, Typeable i, Typeable f)-    => Data (M1 i c f p)---- | @since 4.9.0.0-deriving instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p))-    => Data ((f :+: g) p)---- | @since 4.9.0.0-deriving instance (Typeable (f :: Type -> Type), Typeable (g :: Type -> Type),-          Data p, Data (f (g p)))-    => Data ((f :.: g) p)---- | @since 4.9.0.0-deriving instance Data p => Data (V1 p)---- | @since 4.9.0.0-deriving instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p))-    => Data ((f :*: g) p)---- | @since 4.9.0.0-deriving instance Data Generics.Fixity---- | @since 4.9.0.0-deriving instance Data Associativity---- | @since 4.9.0.0-deriving instance Data SourceUnpackedness---- | @since 4.9.0.0-deriving instance Data SourceStrictness---- | @since 4.9.0.0-deriving instance Data DecidedStrictness--------------------------------------------------------------------------------- Data instances for Data.Ord---- | @since 4.12.0.0-deriving instance Data a => Data (Down a)
− Data/Dynamic.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeApplications #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Dynamic--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ The Dynamic interface provides basic support for dynamic types.------ Operations for injecting values of arbitrary type into--- a dynamically typed value, Dynamic, are provided, together--- with operations for converting dynamic values into a concrete--- (monomorphic) type.-----------------------------------------------------------------------------------module Data.Dynamic-  (--        -- * The @Dynamic@ type-        Dynamic(..),--        -- * Converting to and from @Dynamic@-        toDyn,-        fromDyn,-        fromDynamic,--        -- * Applying functions of dynamic type-        dynApply,-        dynApp,-        dynTypeRep,--        -- * Convenience re-exports-        Typeable--  ) where---import Data.Type.Equality-import Type.Reflection-import Data.Maybe--import GHC.Base-import GHC.Show-import GHC.Exception---------------------------------------------------------------------              The type Dynamic-------------------------------------------------------------------{-|-  A value of type 'Dynamic' is an object encapsulated together with its type.--  A 'Dynamic' may only represent a monomorphic value; an attempt to-  create a value of type 'Dynamic' from a polymorphically-typed-  expression will result in an ambiguity error (see 'toDyn').--  'Show'ing a value of type 'Dynamic' returns a pretty-printed representation-  of the object\'s type; useful for debugging.--}-data Dynamic where-    Dynamic :: forall a. TypeRep a -> a -> Dynamic---- | @since 2.01-instance Show Dynamic where-   -- the instance just prints the type representation.-   showsPrec _ (Dynamic t _) =-          showString "<<" .-          showsPrec 0 t   .-          showString ">>"---- here so that it isn't an orphan:--- | @since 4.0.0.0-instance Exception Dynamic-- -- Use GHC's primitive 'Any' type to hold the dynamically typed value.- --- -- In GHC's new eval/apply execution model this type must not look- -- like a data type.  If it did, GHC would use the constructor convention- -- when evaluating it, and this will go wrong if the object is really a- -- function.  Using Any forces GHC to use- -- a fallback convention for evaluating it that works for all types.---- | Converts an arbitrary value into an object of type 'Dynamic'.------ The type of the object must be an instance of 'Typeable', which--- ensures that only monomorphically-typed objects may be converted to--- 'Dynamic'.  To convert a polymorphic object into 'Dynamic', give it--- a monomorphic type signature.  For example:------ >    toDyn (id :: Int -> Int)----toDyn :: Typeable a => a -> Dynamic-toDyn v = Dynamic typeRep v---- | Converts a 'Dynamic' object back into an ordinary Haskell value of--- the correct type.  See also 'fromDynamic'.-fromDyn :: Typeable a-        => Dynamic      -- ^ the dynamically-typed object-        -> a            -- ^ a default value-        -> a            -- ^ returns: the value of the first argument, if-                        -- it has the correct type, otherwise the value of-                        -- the second argument.-fromDyn (Dynamic t v) def-  | Just HRefl <- t `eqTypeRep` typeOf def = v-  | otherwise                              = def---- | Converts a 'Dynamic' object back into an ordinary Haskell value of--- the correct type.  See also 'fromDyn'.-fromDynamic-        :: forall a. Typeable a-        => Dynamic      -- ^ the dynamically-typed object-        -> Maybe a      -- ^ returns: @'Just' a@, if the dynamically-typed-                        -- object has the correct type (and @a@ is its value),-                        -- or 'Nothing' otherwise.-fromDynamic (Dynamic t v)-  | Just HRefl <- t `eqTypeRep` rep = Just v-  | otherwise                       = Nothing-  where rep = typeRep :: TypeRep a---- (f::(a->b)) `dynApply` (x::a) = (f a)::b-dynApply :: Dynamic -> Dynamic -> Maybe Dynamic-dynApply (Dynamic (Fun ta tr) f) (Dynamic ta' x)-  | Just HRefl <- ta `eqTypeRep` ta'-  , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr-  = Just (Dynamic tr (f x))-dynApply _ _-  = Nothing--dynApp :: Dynamic -> Dynamic -> Dynamic-dynApp f x = case dynApply f x of-             Just r -> r-             Nothing -> errorWithoutStackTrace ("Type error in dynamic application.\n" ++-                               "Can't apply function " ++ show f ++-                               " to argument " ++ show x)--dynTypeRep :: Dynamic -> SomeTypeRep-dynTypeRep (Dynamic tr _) = SomeTypeRep tr
− Data/Either.hs 
@@ -1,344 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- 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------ The Either type, and associated operations.-----------------------------------------------------------------------------------module Data.Either (-   Either(..),-   either,-   lefts,-   rights,-   isLeft,-   isRight,-   fromLeft,-   fromRight,-   partitionEithers,- ) where--import GHC.Base-import GHC.Show-import GHC.Read---- $setup--- Allow the use of some Prelude functions in doctests.--- >>> import Prelude--{---- just for testing-import Test.QuickCheck--}--{-|--The 'Either' type represents values with two possibilities: a value of-type @'Either' a b@ is either @'Left' a@ or @'Right' b@.--The 'Either' type is sometimes used to represent a value which is-either correct or an error; by convention, the 'Left' constructor is-used to hold an error value and the 'Right' constructor is used to-hold a correct value (mnemonic: \"right\" also means \"correct\").--==== __Examples__--The type @'Either' 'String' 'Int'@ is the type of values which can be either-a 'String' or an 'Int'. The 'Left' constructor can be used only on-'String's, and the 'Right' constructor can be used only on 'Int's:-->>> let s = Left "foo" :: Either String Int->>> s-Left "foo"->>> let n = Right 3 :: Either String Int->>> n-Right 3->>> :type s-s :: Either String Int->>> :type n-n :: Either String Int--The 'fmap' from our 'Functor' instance will ignore 'Left' values, but-will apply the supplied function to values contained in a 'Right':-->>> let s = Left "foo" :: Either String Int->>> let n = Right 3 :: Either String Int->>> fmap (*2) s-Left "foo"->>> fmap (*2) n-Right 6--The 'Monad' instance for 'Either' allows us to chain together multiple-actions which may fail, and fail overall if any of the individual-steps failed. First we'll write a function that can either parse an-'Int' from a 'Char', or fail.-->>> import Data.Char ( digitToInt, isDigit )->>> :{-    let parseEither :: Char -> Either String Int-        parseEither c-          | isDigit c = Right (digitToInt c)-          | otherwise = Left "parse error"->>> :}--The following should work, since both @\'1\'@ and @\'2\'@ can be-parsed as 'Int's.-->>> :{-    let parseMultiple :: Either String Int-        parseMultiple = do-          x <- parseEither '1'-          y <- parseEither '2'-          return (x + y)->>> :}-->>> parseMultiple-Right 3--But the following should fail overall, since the first operation where-we attempt to parse @\'m\'@ as an 'Int' will fail:-->>> :{-    let parseMultiple :: Either String Int-        parseMultiple = do-          x <- parseEither 'm'-          y <- parseEither '2'-          return (x + y)->>> :}-->>> parseMultiple-Left "parse error"---}-data  Either a b  =  Left a | Right b-  deriving ( Eq   -- ^ @since 2.01-           , Ord  -- ^ @since 2.01-           , Read -- ^ @since 3.0-           , Show -- ^ @since 3.0-           )---- | @since 3.0-instance Functor (Either a) where-    fmap _ (Left x) = Left x-    fmap f (Right y) = Right (f y)---- | @since 4.9.0.0-instance Semigroup (Either a b) where-    Left _ <> b = b-    a      <> _ = a-#if !defined(__HADDOCK_VERSION__)-    -- workaround https://github.com/haskell/haddock/issues/680-    stimes n x-      | n <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected"-      | otherwise = x-#endif---- | @since 3.0-instance Applicative (Either e) where-    pure          = Right-    Left  e <*> _ = Left e-    Right f <*> r = fmap f r---- | @since 4.4.0.0-instance Monad (Either e) where-    Left  l >>= _ = Left l-    Right r >>= k = k r---- | Case analysis for the 'Either' type.--- If the value is @'Left' a@, apply the first function to @a@;--- if it is @'Right' b@, apply the second function to @b@.------ ==== __Examples__------ We create two values of type @'Either' 'String' 'Int'@, one using the--- 'Left' constructor and another using the 'Right' constructor. Then--- we apply \"either\" the 'Prelude.length' function (if we have a 'String')--- or the \"times-two\" function (if we have an 'Int'):------ >>> let s = Left "foo" :: Either String Int--- >>> let n = Right 3 :: Either String Int--- >>> either length (*2) s--- 3--- >>> either length (*2) n--- 6----either                  :: (a -> c) -> (b -> c) -> Either a b -> c-either f _ (Left x)     =  f x-either _ g (Right y)    =  g y----- | Extracts from a list of 'Either' all the 'Left' elements.--- All the 'Left' elements are extracted in order.------ ==== __Examples__------ Basic usage:------ >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ]--- >>> lefts list--- ["foo","bar","baz"]----lefts   :: [Either a b] -> [a]-lefts x = [a | Left a <- x]-{-# INLINEABLE lefts #-} -- otherwise doesn't get an unfolding, see #13689---- | Extracts from a list of 'Either' all the 'Right' elements.--- All the 'Right' elements are extracted in order.------ ==== __Examples__------ Basic usage:------ >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ]--- >>> rights list--- [3,7]----rights   :: [Either a b] -> [b]-rights x = [a | Right a <- x]-{-# INLINEABLE rights #-} -- otherwise doesn't get an unfolding, see #13689---- | Partitions a list of 'Either' into two lists.--- All the 'Left' elements are extracted, in order, to the first--- component of the output.  Similarly the 'Right' elements are extracted--- to the second component of the output.------ ==== __Examples__------ Basic usage:------ >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ]--- >>> partitionEithers list--- (["foo","bar","baz"],[3,7])------ The pair returned by @'partitionEithers' x@ should be the same--- pair as @('lefts' x, 'rights' x)@:------ >>> let list = [ Left "foo", Right 3, Left "bar", Right 7, Left "baz" ]--- >>> partitionEithers list == (lefts list, rights list)--- True----partitionEithers :: [Either a b] -> ([a],[b])-partitionEithers = foldr (either left right) ([],[])- where-  left  a ~(l, r) = (a:l, r)-  right a ~(l, r) = (l, a:r)---- | Return `True` if the given value is a `Left`-value, `False` otherwise.------ @since 4.7.0.0------ ==== __Examples__------ Basic usage:------ >>> isLeft (Left "foo")--- True--- >>> isLeft (Right 3)--- False------ Assuming a 'Left' value signifies some sort of error, we can use--- 'isLeft' to write a very simple error-reporting function that does--- absolutely nothing in the case of success, and outputs \"ERROR\" if--- any error occurred.------ This example shows how 'isLeft' might be used to avoid pattern--- matching when one does not care about the value contained in the--- constructor:------ >>> import Control.Monad ( when )--- >>> let report e = when (isLeft e) $ putStrLn "ERROR"--- >>> report (Right 1)--- >>> report (Left "parse error")--- ERROR----isLeft :: Either a b -> Bool-isLeft (Left  _) = True-isLeft (Right _) = False---- | Return `True` if the given value is a `Right`-value, `False` otherwise.------ @since 4.7.0.0------ ==== __Examples__------ Basic usage:------ >>> isRight (Left "foo")--- False--- >>> isRight (Right 3)--- True------ Assuming a 'Left' value signifies some sort of error, we can use--- 'isRight' to write a very simple reporting function that only--- outputs \"SUCCESS\" when a computation has succeeded.------ This example shows how 'isRight' might be used to avoid pattern--- matching when one does not care about the value contained in the--- constructor:------ >>> import Control.Monad ( when )--- >>> let report e = when (isRight e) $ putStrLn "SUCCESS"--- >>> report (Left "parse error")--- >>> report (Right 1)--- SUCCESS----isRight :: Either a b -> Bool-isRight (Left  _) = False-isRight (Right _) = True---- | Return the contents of a 'Left'-value or a default value otherwise.------ @since 4.10.0.0------ ==== __Examples__------ Basic usage:------ >>> fromLeft 1 (Left 3)--- 3--- >>> fromLeft 1 (Right "foo")--- 1----fromLeft :: a -> Either a b -> a-fromLeft _ (Left a) = a-fromLeft a _        = a---- | Return the contents of a 'Right'-value or a default value otherwise.------ @since 4.10.0.0------ ==== __Examples__------ Basic usage:------ >>> fromRight 1 (Right 3)--- 3--- >>> fromRight 1 (Left "foo")--- 1----fromRight :: b -> Either a b -> b-fromRight _ (Right b) = b-fromRight b _         = b--{--{---------------------------------------------------------------------  Testing---------------------------------------------------------------------}-prop_partitionEithers :: [Either Int Int] -> Bool-prop_partitionEithers x =-  partitionEithers x == (lefts x, rights x)--}
− Data/Eq.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Eq--- Copyright   :  (c) The University of Glasgow 2005--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ Equality-----------------------------------------------------------------------------------module Data.Eq (-   Eq(..),- ) where--import GHC.Base
− Data/Fixed.hs 
@@ -1,299 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE FlexibleInstances #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Fixed--- Copyright   :  (c) Ashley Yakeley 2005, 2006, 2009--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  Ashley Yakeley <ashley@semantic.org>--- Stability   :  experimental--- Portability :  portable------ This module defines a \"Fixed\" type for fixed-precision arithmetic.--- The parameter to 'Fixed' is any type that's an instance of 'HasResolution'.--- 'HasResolution' has a single method that gives the resolution of the 'Fixed'--- type.------ This module also contains generalisations of 'div', 'mod', and 'divMod' to--- work with any 'Real' instance.-----------------------------------------------------------------------------------module Data.Fixed-(-    div',mod',divMod',--    Fixed(..), HasResolution(..),-    showFixed,-    E0,Uni,-    E1,Deci,-    E2,Centi,-    E3,Milli,-    E6,Micro,-    E9,Nano,-    E12,Pico-) where--import Data.Data-import GHC.TypeLits (KnownNat, natVal)-import GHC.Read-import Text.ParserCombinators.ReadPrec-import Text.Read.Lex--default () -- avoid any defaulting shenanigans---- | Generalisation of 'div' to any instance of 'Real'-div' :: (Real a,Integral b) => a -> a -> b-div' n d = floor ((toRational n) / (toRational d))---- | Generalisation of 'divMod' to any instance of 'Real'-divMod' :: (Real a,Integral b) => a -> a -> (b,a)-divMod' n d = (f,n - (fromIntegral f) * d) where-    f = div' n d---- | Generalisation of 'mod' to any instance of 'Real'-mod' :: (Real a) => a -> a -> a-mod' n d = n - (fromInteger f) * d where-    f = div' n d---- | The type parameter should be an instance of 'HasResolution'.-newtype Fixed (a :: k) = MkFixed Integer-        deriving ( Eq  -- ^ @since 2.01-                 , Ord -- ^ @since 2.01-                 )---- We do this because the automatically derived Data instance requires (Data a) context.--- Our manual instance has the more general (Typeable a) context.-tyFixed :: DataType-tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]-conMkFixed :: Constr-conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix---- | @since 4.1.0.0-instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where-    gfoldl k z (MkFixed a) = k (z MkFixed) a-    gunfold k z _ = k (z MkFixed)-    dataTypeOf _ = tyFixed-    toConstr _ = conMkFixed--class HasResolution (a :: k) where-    resolution :: p a -> Integer---- | For example, @Fixed 1000@ will give you a 'Fixed' with a resolution of 1000.-instance KnownNat n => HasResolution n where-    resolution _ = natVal (Proxy :: Proxy n)--withType :: (Proxy a -> f a) -> f a-withType foo = foo Proxy--withResolution :: (HasResolution a) => (Integer -> f a) -> f a-withResolution foo = withType (foo . resolution)---- | @since 2.01------ Recall that, for numeric types, 'succ' and 'pred' typically add and subtract--- @1@, respectively. This is not true in the case of 'Fixed', whose successor--- and predecessor functions intuitively return the "next" and "previous" values--- in the enumeration. The results of these functions thus depend on the--- resolution of the 'Fixed' value. For example, when enumerating values of--- resolution @10^-3@ of @type Milli = Fixed E3@,------ @---   succ (0.000 :: Milli) == 1.001--- @--------- and likewise------ @---   pred (0.000 :: Milli) == -0.001--- @--------- In other words, 'succ' and 'pred' increment and decrement a fixed-precision--- value by the least amount such that the value's resolution is unchanged.--- For example, @10^-12@ is the smallest (positive) amount that can be added to--- a value of @type Pico = Fixed E12@ without changing its resolution, and so------ @---   succ (0.000000000000 :: Pico) == 0.000000000001--- @--------- and similarly------ @---   pred (0.000000000000 :: Pico) == -0.000000000001--- @--------- This is worth bearing in mind when defining 'Fixed' arithmetic sequences. In--- particular, you may be forgiven for thinking the sequence------ @---   [1..10] :: [Pico]--- @--------- evaluates to @[1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Pico]@.------ However, this is not true. On the contrary, similarly to the above--- implementations of 'succ' and 'pred', @enumFromTo :: Pico -> Pico -> [Pico]@--- has a "step size" of @10^-12@. Hence, the list @[1..10] :: [Pico]@ has--- the form------ @---   [1.000000000000, 1.00000000001, 1.00000000002, ..., 10.000000000000]--- @--------- and contains @9 * 10^12 + 1@ values.-instance Enum (Fixed a) where-    succ (MkFixed a) = MkFixed (succ a)-    pred (MkFixed a) = MkFixed (pred a)-    toEnum = MkFixed . toEnum-    fromEnum (MkFixed a) = fromEnum a-    enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)-    enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)-    enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)-    enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)---- | @since 2.01-instance (HasResolution a) => Num (Fixed a) where-    (MkFixed a) + (MkFixed b) = MkFixed (a + b)-    (MkFixed a) - (MkFixed b) = MkFixed (a - b)-    fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))-    negate (MkFixed a) = MkFixed (negate a)-    abs (MkFixed a) = MkFixed (abs a)-    signum (MkFixed a) = fromInteger (signum a)-    fromInteger i = withResolution (\res -> MkFixed (i * res))---- | @since 2.01-instance (HasResolution a) => Real (Fixed a) where-    toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))---- | @since 2.01-instance (HasResolution a) => Fractional (Fixed a) where-    fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)-    recip fa@(MkFixed a) = MkFixed (div (res * res) a) where-        res = resolution fa-    fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))---- | @since 2.01-instance (HasResolution a) => RealFrac (Fixed a) where-    properFraction a = (i,a - (fromIntegral i)) where-        i = truncate a-    truncate f = truncate (toRational f)-    round f = round (toRational f)-    ceiling f = ceiling (toRational f)-    floor f = floor (toRational f)--chopZeros :: Integer -> String-chopZeros 0 = ""-chopZeros a | mod a 10 == 0 = chopZeros (div a 10)-chopZeros a = show a---- only works for positive a-showIntegerZeros :: Bool -> Int -> Integer -> String-showIntegerZeros True _ 0 = ""-showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where-    s = show a-    s' = if chopTrailingZeros then chopZeros a else s--withDot :: String -> String-withDot "" = ""-withDot s = '.':s---- | First arg is whether to chop off trailing zeros-showFixed :: (HasResolution a) => Bool -> Fixed a -> String-showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))-showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where-    res = resolution fa-    (i,d) = divMod a res-    -- enough digits to be unambiguous-    digits = ceiling (logBase 10 (fromInteger res) :: Double)-    maxnum = 10 ^ digits-    -- read floors, so show must ceil for `read . show = id` to hold. See #9240-    fracNum = divCeil (d * maxnum) res-    divCeil x y = (x + y - 1) `div` y---- | @since 2.01-instance (HasResolution a) => Show (Fixed a) where-    showsPrec p n = showParen (p > 6 && n < 0) $ showString $ showFixed False n---- | @since 4.3.0.0-instance (HasResolution a) => Read (Fixed a) where-    readPrec     = readNumber convertFixed-    readListPrec = readListPrecDefault-    readList     = readListDefault--convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)-convertFixed (Number n)- | Just (i, f) <- numberToFixed e n =-    return (fromInteger i + (fromInteger f / (10 ^ e)))-    where r = resolution (Proxy :: Proxy a)-          -- round 'e' up to help make the 'read . show == id' property-          -- possible also for cases where 'resolution' is not a-          -- power-of-10, such as e.g. when 'resolution = 128'-          e = ceiling (logBase 10 (fromInteger r) :: Double)-convertFixed _ = pfail--data E0---- | @since 4.1.0.0-instance HasResolution E0 where-    resolution _ = 1--- | resolution of 1, this works the same as Integer-type Uni = Fixed E0--data E1---- | @since 4.1.0.0-instance HasResolution E1 where-    resolution _ = 10--- | resolution of 10^-1 = .1-type Deci = Fixed E1--data E2---- | @since 4.1.0.0-instance HasResolution E2 where-    resolution _ = 100--- | resolution of 10^-2 = .01, useful for many monetary currencies-type Centi = Fixed E2--data E3---- | @since 4.1.0.0-instance HasResolution E3 where-    resolution _ = 1000--- | resolution of 10^-3 = .001-type Milli = Fixed E3--data E6---- | @since 2.01-instance HasResolution E6 where-    resolution _ = 1000000--- | resolution of 10^-6 = .000001-type Micro = Fixed E6--data E9---- | @since 4.1.0.0-instance HasResolution E9 where-    resolution _ = 1000000000--- | resolution of 10^-9 = .000000001-type Nano = Fixed E9--data E12---- | @since 2.01-instance HasResolution E12 where-    resolution _ = 1000000000000--- | resolution of 10^-12 = .000000000001-type Pico = Fixed E12
− Data/Foldable.hs 
@@ -1,2511 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Foldable--- Copyright   :  Ross Paterson 2005--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Class of data structures that can be folded to a summary value.-----------------------------------------------------------------------------------module Data.Foldable (-    Foldable(..),-    -- * Special biased folds-    foldrM,-    foldlM,-    -- * Folding actions-    -- ** Applicative actions-    traverse_,-    for_,-    sequenceA_,-    asum,-    -- ** Monadic actions-    mapM_,-    forM_,-    sequence_,-    msum,-    -- * Specialized folds-    concat,-    concatMap,-    and,-    or,-    any,-    all,-    maximumBy,-    minimumBy,-    -- * Searches-    notElem,-    find--    -- * Overview-    -- $overview--    -- ** Expectation of efficient left-to-right iteration-    -- $chirality--    -- ** Recursive and corecursive reduction-    -- $reduction--    -- *** Strict recursive folds-    -- $strict--    -- **** List of strict functions-    -- $strictlist--    -- *** Lazy corecursive folds-    -- $lazy--    -- **** List of lazy functions-    -- $lazylist--    -- *** Short-circuit folds-    -- $shortcircuit--    -- **** List of short-circuit functions-    -- $shortlist--    -- *** Hybrid folds-    -- $hybrid--    -- ** Generative Recursion-    -- $generative--    -- ** Avoiding multi-pass folds-    -- $multipass--    -- * Defining instances-    -- $instances--    -- *** Being strict by being lazy-    -- $strictlazy--    -- * Laws-    -- $laws--    -- * Notes-    -- $notes--    -- ** Generally linear-time `elem`-    -- $linear--    -- * See also-    -- $also-    ) where--import Data.Bool-import Data.Either-import Data.Eq-import Data.Functor.Utils (Max(..), Min(..), (#.))-import qualified GHC.List as List-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.Proxy--import GHC.Arr  ( Array(..), elems, numElements,-                  foldlElems, foldrElems,-                  foldlElems', foldrElems',-                  foldl1Elems, foldr1Elems)-import GHC.Base hiding ( foldr )-import GHC.Generics-import GHC.Tuple (Solo (..))-import GHC.Num  ( Num(..) )---- $setup--- >>> :set -XDeriveFoldable--- >>> import Prelude--- >>> import Data.Monoid (Product (..), Sum (..))--- >>> data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) deriving (Show, Foldable)--infix  4 `elem`, `notElem`---- XXX: Missing haddock feature.  Links to anchors in other modules--- don't have a sensible way to name the link within the module itself.--- Thus, the below "Data.Foldable#overview" works well when shown as--- @Data.Foldable@ from other modules, but in the home module it should--- be possible to specify alternative link text. :-(---- | The Foldable class represents data structures that can be reduced to a--- summary value one element at a time.  Strict left-associative folds are a--- good fit for space-efficient reduction, while lazy right-associative folds--- are a good fit for corecursive iteration, or for folds that short-circuit--- after processing an initial subsequence of the structure's elements.------ Instances can be derived automatically by enabling the @DeriveFoldable@--- extension.  For example, a derived instance for a binary tree might be:------ > {-# LANGUAGE DeriveFoldable #-}--- > data Tree a = Empty--- >             | Leaf a--- >             | Node (Tree a) a (Tree a)--- >     deriving Foldable------ A more detailed description can be found in the __Overview__ section of--- "Data.Foldable#overview".------ For the class laws see the __Laws__ section of "Data.Foldable#laws".----class Foldable t where-    {-# MINIMAL foldMap | foldr #-}--    -- | Given a structure with elements whose type is a 'Monoid', combine them-    -- via the monoid's @('<>')@ operator.  This fold is right-associative and-    -- lazy in the accumulator.  When you need a strict left-associative fold,-    -- use 'foldMap'' instead, with 'id' as the map.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> fold [[1, 2, 3], [4, 5], [6], []]-    -- [1,2,3,4,5,6]-    ---    -- >>> fold $ Node (Leaf (Sum 1)) (Sum 3) (Leaf (Sum 5))-    -- Sum {getSum = 9}-    ---    -- Folds of unbounded structures do not terminate when the monoid's-    -- @('<>')@ operator is strict:-    ---    -- >>> fold (repeat Nothing)-    -- * Hangs forever *-    ---    -- Lazy corecursive folds of unbounded structures are fine:-    ---    -- >>> take 12 $ fold $ map (\i -> [i..i+2]) [0..]-    -- [0,1,2,1,2,3,2,3,4,3,4,5]-    -- >>> sum $ take 4000000 $ fold $ map (\i -> [i..i+2]) [0..]-    -- 2666668666666-    ---    fold :: Monoid m => t m -> m-    fold = foldMap id--    -- | Map each element of the structure into a monoid, and combine the-    -- results with @('<>')@.  This fold is right-associative and lazy in the-    -- accumulator.  For strict left-associative folds consider 'foldMap''-    -- instead.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> foldMap Sum [1, 3, 5]-    -- Sum {getSum = 9}-    ---    -- >>> foldMap Product [1, 3, 5]-    -- Product {getProduct = 15}-    ---    -- >>> foldMap (replicate 3) [1, 2, 3]-    -- [1,1,1,2,2,2,3,3,3]-    ---    -- When a Monoid's @('<>')@ is lazy in its second argument, 'foldMap' can-    -- return a result even from an unbounded structure.  For example, lazy-    -- accumulation enables "Data.ByteString.Builder" to efficiently serialise-    -- large data structures and produce the output incrementally:-    ---    -- >>> import qualified Data.ByteString.Lazy as L-    -- >>> import qualified Data.ByteString.Builder as B-    -- >>> let bld :: Int -> B.Builder; bld i = B.intDec i <> B.word8 0x20-    -- >>> let lbs = B.toLazyByteString $ foldMap bld [0..]-    -- >>> L.take 64 lbs-    -- "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24"-    ---    foldMap :: Monoid m => (a -> m) -> t a -> m-    {-# INLINE foldMap #-}-    -- This INLINE allows more list functions to fuse.  See #9848.-    foldMap f = foldr (mappend . f) mempty--    -- | A left-associative variant of 'foldMap' that is strict in the-    -- accumulator.  Use this method for strict reduction when partial-    -- results are merged via @('<>')@.-    ---    -- ==== __Examples__-    ---    -- Define a 'Monoid' over finite bit strings under 'xor'.  Use it to-    -- strictly compute the `xor` of a list of 'Int' values.-    ---    -- >>> :set -XGeneralizedNewtypeDeriving-    -- >>> import Data.Bits (Bits, FiniteBits, xor, zeroBits)-    -- >>> import Data.Foldable (foldMap')-    -- >>> import Numeric (showHex)-    -- >>>-    -- >>> newtype X a = X a deriving (Eq, Bounded, Enum, Bits, FiniteBits)-    -- >>> instance Bits a => Semigroup (X a) where X a <> X b = X (a `xor` b)-    -- >>> instance Bits a => Monoid    (X a) where mempty     = X zeroBits-    -- >>>-    -- >>> let bits :: [Int]; bits = [0xcafe, 0xfeed, 0xdeaf, 0xbeef, 0x5411]-    -- >>> (\ (X a) -> showString "0x" . showHex a $ "") $ foldMap' X bits-    -- "0x42"-    ---    -- @since 4.13.0.0-    foldMap' :: Monoid m => (a -> m) -> t a -> m-    foldMap' f = foldl' (\ acc a -> acc <> f a) mempty--    -- | Right-associative fold of a structure, lazy in the accumulator.-    ---    -- 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, given an-    -- operator lazy in its right argument, 'foldr' can produce a terminating-    -- expression from an unbounded list.-    ---    -- For a general 'Foldable' structure this should be semantically identical-    -- to,-    ---    -- @foldr f z = 'List.foldr' f z . 'toList'@-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> foldr (||) False [False, True, False]-    -- True-    ---    -- >>> foldr (||) False []-    -- False-    ---    -- >>> foldr (\c acc -> acc ++ [c]) "foo" ['a', 'b', 'c', 'd']-    -- "foodcba"-    ---    -- ===== Infinite structures-    ---    -- ⚠️ Applying 'foldr' to infinite structures usually doesn't terminate.-    ---    -- It may still terminate under one of the following conditions:-    ---    -- * the folding function is short-circuiting-    -- * the folding function is lazy on its second argument-    ---    -- ====== Short-circuiting-    ---    -- @('||')@ short-circuits on 'True' values, so the following terminates-    -- because there is a 'True' value finitely far from the left side:-    ---    -- >>> foldr (||) False (True : repeat False)-    -- True-    ---    -- But the following doesn't terminate:-    ---    -- >>> foldr (||) False (repeat False ++ [True])-    -- * Hangs forever *-    ---    -- ====== Laziness in the second argument-    ---    -- Applying 'foldr' to infinite structures terminates when the operator is-    -- lazy in its second argument (the initial accumulator is never used in-    -- this case, and so could be left 'undefined', but @[]@ is more clear):-    ---    -- >>> take 5 $ foldr (\i acc -> i : fmap (+3) acc) [] (repeat 1)-    -- [1,4,7,10,13]-    foldr :: (a -> b -> b) -> b -> t a -> b-    foldr f z t = appEndo (foldMap (Endo #. f) t) z--    -- | Right-associative fold of a structure, strict in the accumulator.-    -- This is rarely what you want.-    ---    -- @since 4.6.0.0-    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, lazy in the accumulator.  This-    -- is rarely what you want, but can work well for structures with efficient-    -- right-to-left sequencing and an operator that is lazy in its left-    -- argument.-    ---    -- 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.  Like all left-associative folds,-    -- 'foldl' will diverge if given an infinite list.-    ---    -- If you want an efficient strict left-fold, you probably want to use-    -- 'foldl'' instead of 'foldl'.  The reason for this is that the 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 \(\mathcal{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'@-    ---    -- ==== __Examples__-    ---    -- The first example is a strict fold, which in practice is best performed-    -- with 'foldl''.-    ---    -- >>> foldl (+) 42 [1,2,3,4]-    -- 52-    ---    -- Though the result below is lazy, the input is reversed before prepending-    -- it to the initial accumulator, so corecursion begins only after traversing-    -- the entire input string.-    ---    -- >>> foldl (\acc c -> c : acc) "abcd" "efgh"-    -- "hgfeabcd"-    ---    -- A left fold of a structure that is infinite on the right cannot-    -- terminate, even when for any finite input the fold just returns the-    -- initial accumulator:-    ---    -- >>> foldl (\a _ -> a) 0 $ repeat 1-    -- * Hangs forever *-    ---    -- WARNING: When it comes to lists, you always want to use either 'foldl'' or 'foldr' instead.-    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.-    ---    -- 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 structure to a single strict result (e.g. 'sum').-    ---    -- For a general 'Foldable' structure this should be semantically identical-    -- to,-    ---    -- @foldl' f z = 'List.foldl'' f z . 'toList'@-    ---    -- @since 4.6.0.0-    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--    -- | A variant of 'foldr' that has no base case,-    -- and thus may only be applied to non-empty structures.-    ---    -- This function is non-total and will raise a runtime exception if the-    -- structure happens to be empty.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> foldr1 (+) [1..4]-    -- 10-    ---    -- >>> foldr1 (+) []-    -- Exception: Prelude.foldr1: empty list-    ---    -- >>> foldr1 (+) Nothing-    -- *** Exception: foldr1: empty structure-    ---    -- >>> foldr1 (-) [1..4]-    -- -2-    ---    -- >>> foldr1 (&&) [True, False, True, True]-    -- False-    ---    -- >>> foldr1 (||) [False, False, True, True]-    -- True-    ---    -- >>> foldr1 (+) [1..]-    -- * Hangs forever *-    foldr1 :: (a -> a -> a) -> t a -> a-    foldr1 f xs = fromMaybe (errorWithoutStackTrace "foldr1: empty structure")-                    (foldr mf Nothing xs)-      where-        mf x m = Just (case m of-                         Nothing -> x-                         Just y  -> f x y)--    -- | A variant of 'foldl' that has no base case,-    -- and thus may only be applied to non-empty structures.-    ---    -- This function is non-total and will raise a runtime exception if the-    -- structure happens to be empty.-    ---    -- @'foldl1' f = 'List.foldl1' f . 'toList'@-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> foldl1 (+) [1..4]-    -- 10-    ---    -- >>> foldl1 (+) []-    -- *** Exception: Prelude.foldl1: empty list-    ---    -- >>> foldl1 (+) Nothing-    -- *** Exception: foldl1: empty structure-    ---    -- >>> foldl1 (-) [1..4]-    -- -8-    ---    -- >>> foldl1 (&&) [True, False, True, True]-    -- False-    ---    -- >>> foldl1 (||) [False, False, True, True]-    -- True-    ---    -- >>> foldl1 (+) [1..]-    -- * Hangs forever *-    foldl1 :: (a -> a -> a) -> t a -> a-    foldl1 f xs = fromMaybe (errorWithoutStackTrace "foldl1: empty structure")-                    (foldl mf Nothing xs)-      where-        mf m y = Just (case m of-                         Nothing -> y-                         Just x  -> f x y)--    -- | List of elements of a structure, from left to right.  If the entire-    -- list is intended to be reduced via a fold, just fold the structure-    -- directly bypassing the list.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> toList Nothing-    -- []-    ---    -- >>> toList (Just 42)-    -- [42]-    ---    -- >>> toList (Left "foo")-    -- []-    ---    -- >>> toList (Node (Leaf 5) 17 (Node Empty 12 (Leaf 8)))-    -- [5,17,12,8]-    ---    -- For lists, 'toList' is the identity:-    ---    -- >>> toList [1, 2, 3]-    -- [1,2,3]-    ---    -- @since 4.8.0.0-    toList :: t a -> [a]-    {-# INLINE toList #-}-    toList t = build (\ c n -> foldr c n t)--    -- | Test whether the structure is empty.  The default implementation is-    -- Left-associative and lazy in both the initial element and the-    -- accumulator.  Thus optimised for structures where the first element can-    -- be accessed in constant time.  Structures where this is not the case-    -- should have a non-default implementation.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> null []-    -- True-    ---    -- >>> null [1]-    -- False-    ---    -- 'null' is expected to terminate even for infinite structures.-    -- The default implementation terminates provided the structure-    -- is bounded on the left (there is a leftmost element).-    ---    -- >>> null [1..]-    -- False-    ---    -- @since 4.8.0.0-    null :: t a -> Bool-    null = foldr (\_ _ -> False) True--    -- | Returns the size/length of a finite structure as an 'Int'.  The-    -- default implementation just counts elements starting with the leftmost.-    -- Instances for structures that can compute the element count faster-    -- than via element-by-element counting, should provide a specialised-    -- implementation.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> length []-    -- 0-    ---    -- >>> length ['a', 'b', 'c']-    -- 3-    -- >>> length [1..]-    -- * Hangs forever *-    ---    -- @since 4.8.0.0-    length :: t a -> Int-    length = foldl' (\c _ -> c+1) 0--    -- | Does the element occur in the structure?-    ---    -- Note: 'elem' is often used in infix form.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> 3 `elem` []-    -- False-    ---    -- >>> 3 `elem` [1,2]-    -- False-    ---    -- >>> 3 `elem` [1,2,3,4,5]-    -- True-    ---    -- For infinite structures, the default implementation of 'elem'-    -- terminates if the sought-after value exists at a finite distance-    -- from the left side of the structure:-    ---    -- >>> 3 `elem` [1..]-    -- True-    ---    -- >>> 3 `elem` ([4..] ++ [3])-    -- * Hangs forever *-    ---    -- @since 4.8.0.0-    elem :: Eq a => a -> t a -> Bool-    elem = any . (==)--    -- | The largest element of a non-empty structure.-    ---    -- This function is non-total and will raise a runtime exception if the-    -- structure happens to be empty.  A structure that supports random access-    -- and maintains its elements in order should provide a specialised-    -- implementation to return the maximum in faster than linear time.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> maximum [1..10]-    -- 10-    ---    -- >>> maximum []-    -- *** Exception: Prelude.maximum: empty list-    ---    -- >>> maximum Nothing-    -- *** Exception: maximum: empty structure-    ---    -- WARNING: This function is partial for possibly-empty structures like lists.-    ---    -- @since 4.8.0.0-    maximum :: forall a . Ord a => t a -> a-    maximum = fromMaybe (errorWithoutStackTrace "maximum: empty structure") .-       getMax . foldMap' (Max #. (Just :: a -> Maybe a))-    {-# INLINEABLE maximum #-}--    -- | The least element of a non-empty structure.-    ---    -- This function is non-total and will raise a runtime exception if the-    -- structure happens to be empty.  A structure that supports random access-    -- and maintains its elements in order should provide a specialised-    -- implementation to return the minimum in faster than linear time.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> minimum [1..10]-    -- 1-    ---    -- >>> minimum []-    -- *** Exception: Prelude.minimum: empty list-    ---    -- >>> minimum Nothing-    -- *** Exception: minimum: empty structure-    ---    -- WARNING: This function is partial for possibly-empty structures like lists.-    ---    -- @since 4.8.0.0-    minimum :: forall a . Ord a => t a -> a-    minimum = fromMaybe (errorWithoutStackTrace "minimum: empty structure") .-       getMin . foldMap' (Min #. (Just :: a -> Maybe a))-    {-# INLINEABLE minimum #-}--    -- | The 'sum' function computes the sum of the numbers of a structure.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> sum []-    -- 0-    ---    -- >>> sum [42]-    -- 42-    ---    -- >>> sum [1..10]-    -- 55-    ---    -- >>> sum [4.1, 2.0, 1.7]-    -- 7.8-    ---    -- >>> sum [1..]-    -- * Hangs forever *-    ---    -- @since 4.8.0.0-    sum :: Num a => t a -> a-    sum = getSum #. foldMap' Sum-    {-# INLINEABLE sum #-}--    -- | The 'product' function computes the product of the numbers of a-    -- structure.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- >>> product []-    -- 1-    ---    -- >>> product [42]-    -- 42-    ---    -- >>> product [1..10]-    -- 3628800-    ---    -- >>> product [4.1, 2.0, 1.7]-    -- 13.939999999999998-    ---    -- >>> product [1..]-    -- * Hangs forever *-    ---    -- @since 4.8.0.0-    product :: Num a => t a -> a-    product = getProduct #. foldMap' Product-    {-# INLINEABLE product #-}---- instances for Prelude types---- | @since 2.01-instance Foldable Maybe where-    foldMap = maybe mempty--    foldr _ z Nothing = z-    foldr f z (Just x) = f x z--    foldl _ z Nothing = z-    foldl f z (Just x) = f z x---- | @since 2.01-instance Foldable [] where-    elem    = List.elem-    foldl   = List.foldl-    foldl'  = List.foldl'-    foldl1  = List.foldl1-    foldr   = List.foldr-    foldr1  = List.foldr1-    length  = List.length-    maximum = List.maximum-    minimum = List.minimum-    null    = List.null-    product = List.product-    sum     = List.sum-    toList  = id---- | @since 4.9.0.0-instance Foldable NonEmpty where-  foldr f z ~(a :| as) = f a (List.foldr f z as)-  foldl f z (a :| as) = List.foldl f (f z a) as-  foldl1 f (a :| as) = List.foldl f a as--  -- GHC isn't clever enough to transform the default definition-  -- into anything like this, so we'd end up shuffling a bunch of-  -- Maybes around.-  foldr1 f (p :| ps) = foldr go id ps p-    where-      go x r prev = f prev (r x)--  -- We used to say-  ---  --   length (_ :| as) = 1 + length as-  ---  -- but the default definition is better, counting from 1.-  ---  -- The default definition also works great for null and foldl'.-  -- As usual for cons lists, foldr' is basically hopeless.--  foldMap f ~(a :| as) = f a `mappend` foldMap f as-  fold ~(m :| ms) = m `mappend` fold ms-  toList ~(a :| as) = a : as---- | @since 4.7.0.0-instance Foldable (Either a) where-    foldMap _ (Left _) = mempty-    foldMap f (Right y) = f y--    foldr _ z (Left _) = z-    foldr f z (Right y) = f y z--    length (Left _)  = 0-    length (Right _) = 1--    null             = isLeft---- | @since 4.15-deriving instance Foldable Solo---- | @since 4.7.0.0-instance Foldable ((,) a) where-    foldMap f (_, y) = f y--    foldr f z (_, y) = f y z-    length _  = 1-    null _ = False---- | @since 4.8.0.0-instance Foldable (Array i) where-    foldr = foldrElems-    foldl = foldlElems-    foldl' = foldlElems'-    foldr' = foldrElems'-    foldl1 = foldl1Elems-    foldr1 = foldr1Elems-    toList = elems-    length = numElements-    null a = numElements a == 0---- | @since 4.7.0.0-instance Foldable Proxy where-    foldMap _ _ = mempty-    {-# INLINE foldMap #-}-    fold _ = mempty-    {-# INLINE fold #-}-    foldr _ z _ = z-    {-# INLINE foldr #-}-    foldl _ z _ = z-    {-# INLINE foldl #-}-    foldl1 _ _ = errorWithoutStackTrace "foldl1: Proxy"-    foldr1 _ _ = errorWithoutStackTrace "foldr1: Proxy"-    length _   = 0-    null _     = True-    elem _ _   = False-    sum _      = 0-    product _  = 1---- | @since 4.8.0.0-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]---- | @since 4.8.0.0-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]---- | @since 4.8.0.0-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]---- | @since 4.8.0.0-instance Foldable First where-    foldMap f = foldMap f . getFirst---- | @since 4.8.0.0-instance Foldable Last where-    foldMap f = foldMap f . getLast---- | @since 4.12.0.0-instance (Foldable f) => Foldable (Alt f) where-    foldMap f = foldMap f . getAlt---- | @since 4.12.0.0-instance (Foldable f) => Foldable (Ap f) where-    foldMap f = foldMap f . getAp---- Instances for GHC.Generics--- | @since 4.9.0.0-instance Foldable U1 where-    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---- | @since 4.9.0.0-deriving instance Foldable V1---- | @since 4.9.0.0-deriving instance Foldable Par1---- | @since 4.9.0.0-deriving instance Foldable f => Foldable (Rec1 f)---- | @since 4.9.0.0-deriving instance Foldable (K1 i c)---- | @since 4.9.0.0-deriving instance Foldable f => Foldable (M1 i c f)---- | @since 4.9.0.0-deriving instance (Foldable f, Foldable g) => Foldable (f :+: g)---- | @since 4.9.0.0-deriving instance (Foldable f, Foldable g) => Foldable (f :*: g)---- | @since 4.9.0.0-deriving instance (Foldable f, Foldable g) => Foldable (f :.: g)---- | @since 4.9.0.0-deriving instance Foldable UAddr---- | @since 4.9.0.0-deriving instance Foldable UChar---- | @since 4.9.0.0-deriving instance Foldable UDouble---- | @since 4.9.0.0-deriving instance Foldable UFloat---- | @since 4.9.0.0-deriving instance Foldable UInt---- | @since 4.9.0.0-deriving instance Foldable UWord---- Instances for Data.Ord--- | @since 4.12.0.0-deriving instance Foldable Down---- | Right-to-left monadic fold over the elements of a structure.------ Given a structure @t@ with elements @(a, b, c, ..., x, y)@, the result of--- a fold with an operator function @f@ is equivalent to:------ > foldrM f z t = do--- >     yy <- f y z--- >     xx <- f x yy--- >     ...--- >     bb <- f b cc--- >     aa <- f a bb--- >     return aa -- Just @return z@ when the structure is empty------ For a Monad @m@, given two functions @f1 :: a -> m b@ and @f2 :: b -> m c@,--- their Kleisli composition @(f1 >=> f2) :: a -> m c@ is defined by:------ > (f1 >=> f2) a = f1 a >>= f2------ Another way of thinking about @foldrM@ is that it amounts to an application--- to @z@ of a Kleisli composition:------ > foldrM f z t = f y >=> f x >=> ... >=> f b >=> f a $ z------ The monadic effects of @foldrM@ are sequenced from right to left, and e.g.--- folds of infinite lists will diverge.------ If at some step the bind operator @('>>=')@ short-circuits (as with, e.g.,--- 'mzero' in a 'MonadPlus'), the evaluated effects will be from a tail of the--- element sequence.  If you want to evaluate the monadic effects in--- left-to-right order, or perhaps be able to short-circuit after an initial--- sequence of elements, you'll need to use `foldlM` instead.------ If the monadic effects don't short-circuit, the outermost application of--- @f@ is to the leftmost element @a@, so that, ignoring effects, the result--- looks like a right fold:------ > a `f` (b `f` (c `f` (... (x `f` (y `f` z))))).------ ==== __Examples__------ Basic usage:------ >>> let f i acc = do { print i ; return $ i : acc }--- >>> foldrM f [] [0..3]--- 3--- 2--- 1--- 0--- [0,1,2,3]----foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b-foldrM f z0 xs = foldl c return xs z0-  -- See Note [List fusion and continuations in 'c']-  where c k x z = f x z >>= k-        {-# INLINE c #-}---- | Left-to-right monadic fold over the elements of a structure.------ Given a structure @t@ with elements @(a, b, ..., w, x, y)@, the result of--- a fold with an operator function @f@ is equivalent to:------ > foldlM f z t = do--- >     aa <- f z a--- >     bb <- f aa b--- >     ...--- >     xx <- f ww x--- >     yy <- f xx y--- >     return yy -- Just @return z@ when the structure is empty------ For a Monad @m@, given two functions @f1 :: a -> m b@ and @f2 :: b -> m c@,--- their Kleisli composition @(f1 >=> f2) :: a -> m c@ is defined by:------ > (f1 >=> f2) a = f1 a >>= f2------ Another way of thinking about @foldlM@ is that it amounts to an application--- to @z@ of a Kleisli composition:------ > foldlM f z t =--- >     flip f a >=> flip f b >=> ... >=> flip f x >=> flip f y $ z------ The monadic effects of @foldlM@ are sequenced from left to right.------ If at some step the bind operator @('>>=')@ short-circuits (as with, e.g.,--- 'mzero' in a 'MonadPlus'), the evaluated effects will be from an initial--- segment of the element sequence.  If you want to evaluate the monadic--- effects in right-to-left order, or perhaps be able to short-circuit after--- processing a tail of the sequence of elements, you'll need to use `foldrM`--- instead.------ If the monadic effects don't short-circuit, the outermost application of--- @f@ is to the rightmost element @y@, so that, ignoring effects, the result--- looks like a left fold:------ > ((((z `f` a) `f` b) ... `f` w) `f` x) `f` y------ ==== __Examples__------ Basic usage:------ >>> let f a e = do { print e ; return $ e : a }--- >>> foldlM f [] [0..3]--- 0--- 1--- 2--- 3--- [3,2,1,0]----foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b-foldlM f z0 xs = foldr c return xs z0-  -- See Note [List fusion and continuations in 'c']-  where c x k z = f z x >>= k-        {-# INLINE c #-}---- | Map each element of a structure to an 'Applicative' action, evaluate these--- actions from left to right, and ignore the results.  For a version that--- doesn't ignore the results see 'Data.Traversable.traverse'.------ 'traverse_' is just like 'mapM_', but generalised to 'Applicative' actions.------ ==== __Examples__------ Basic usage:------ >>> traverse_ print ["Hello", "world", "!"]--- "Hello"--- "world"--- "!"-traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()-traverse_ f = foldr c (pure ())-  -- See Note [List fusion and continuations in 'c']-  where c x k = f x *> k-        {-# INLINE c #-}---- | 'for_' is 'traverse_' with its arguments flipped.  For a version--- that doesn't ignore the results see 'Data.Traversable.for'.  This--- is 'forM_' generalised to 'Applicative' actions.------ 'for_' is just like 'forM_', but generalised to 'Applicative' actions.------ ==== __Examples__------ Basic usage:------ >>> for_ [1..4] print--- 1--- 2--- 3--- 4-for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()-{-# INLINE for_ #-}-for_ = flip traverse_---- | Map each element of a structure to a monadic action, evaluate--- these actions from left to right, and ignore the results.  For a--- version that doesn't ignore the results see--- 'Data.Traversable.mapM'.------ 'mapM_' is just like 'traverse_', but specialised to monadic actions.----mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()-mapM_ f = foldr c (return ())-  -- See Note [List fusion and continuations in 'c']-  where c x k = f x >> k-        {-# INLINE c #-}---- | 'forM_' is 'mapM_' with its arguments flipped.  For a version that--- doesn't ignore the results see 'Data.Traversable.forM'.------ 'forM_' is just like 'for_', but specialised to monadic actions.----forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()-{-# INLINE forM_ #-}-forM_ = flip mapM_---- | Evaluate each action in the structure from left to right, and--- ignore the results.  For a version that doesn't ignore the results--- see 'Data.Traversable.sequenceA'.------ 'sequenceA_' is just like 'sequence_', but generalised to 'Applicative'--- actions.------ ==== __Examples__------ Basic usage:------ >>> sequenceA_ [print "Hello", print "world", print "!"]--- "Hello"--- "world"--- "!"-sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()-sequenceA_ = foldr c (pure ())-  -- See Note [List fusion and continuations in 'c']-  where c m k = m *> k-        {-# INLINE c #-}---- | Evaluate each monadic action in the structure from left to right,--- and ignore the results.  For a version that doesn't ignore the--- results see 'Data.Traversable.sequence'.------ 'sequence_' is just like 'sequenceA_', but specialised to monadic--- actions.----sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()-sequence_ = foldr c (return ())-  -- See Note [List fusion and continuations in 'c']-  where c m k = m >> k-        {-# INLINE c #-}---- | The sum of a collection of actions, generalizing 'concat'.------ 'asum' is just like 'msum', but generalised to 'Alternative'.------ ==== __Examples__------ Basic usage:------ >>> asum [Just "Hello", Nothing, Just "World"]--- Just "Hello"-asum :: (Foldable t, Alternative f) => t (f a) -> f a-{-# INLINE asum #-}-asum = foldr (<|>) empty---- | The sum of a collection of actions, generalizing 'concat'.------ 'msum' is just like 'asum', but specialised to 'MonadPlus'.----msum :: (Foldable t, MonadPlus m) => t (m a) -> m a-{-# INLINE msum #-}-msum = asum---- | The concatenation of all the elements of a container of lists.------ ==== __Examples__------ Basic usage:------ >>> concat (Just [1, 2, 3])--- [1,2,3]------ >>> concat (Left 42)--- []------ >>> concat [[1, 2, 3], [4, 5], [6], []]--- [1,2,3,4,5,6]-concat :: Foldable t => t [a] -> [a]-concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)-{-# INLINE concat #-}---- | Map a function over all the elements of a container and concatenate--- the resulting lists.------ ==== __Examples__------ Basic usage:------ >>> concatMap (take 3) [[1..], [10..], [100..], [1000..]]--- [1,2,3,10,11,12,100,101,102,1000,1001,1002]------ >>> concatMap (take 3) (Just [1..])--- [1,2,3]-concatMap :: Foldable t => (a -> [b]) -> t a -> [b]-concatMap f xs = build (\c n -> foldr (\x b -> foldr c b (f x)) n xs)-{-# INLINE concatMap #-}---- These use foldr rather than foldMap to avoid repeated concatenation.---- | 'and' returns the conjunction of a container of Bools.  For the--- result to be 'True', the container must be finite; 'False', however,--- results from a 'False' value finitely far from the left end.------ ==== __Examples__------ Basic usage:------ >>> and []--- True------ >>> and [True]--- True------ >>> and [False]--- False------ >>> and [True, True, False]--- False------ >>> and (False : repeat True) -- Infinite list [False,True,True,True,...--- False------ >>> and (repeat True)--- * Hangs forever *-and :: Foldable t => t Bool -> Bool-and = getAll #. foldMap All---- | 'or' returns the disjunction of a container of Bools.  For the--- result to be 'False', the container must be finite; 'True', however,--- results from a 'True' value finitely far from the left end.------ ==== __Examples__------ Basic usage:------ >>> or []--- False------ >>> or [True]--- True------ >>> or [False]--- False------ >>> or [True, True, False]--- True------ >>> or (True : repeat False) -- Infinite list [True,False,False,False,...--- True------ >>> or (repeat False)--- * Hangs forever *-or :: Foldable t => t Bool -> Bool-or = getAny #. foldMap Any---- | Determines whether any element of the structure satisfies the predicate.------ ==== __Examples__------ Basic usage:------ >>> any (> 3) []--- False------ >>> any (> 3) [1,2]--- False------ >>> any (> 3) [1,2,3,4,5]--- True------ >>> any (> 3) [1..]--- True------ >>> any (> 3) [0, -1..]--- * Hangs forever *-any :: Foldable t => (a -> Bool) -> t a -> Bool-any p = getAny #. foldMap (Any #. p)---- | Determines whether all elements of the structure satisfy the predicate.------ ==== __Examples__------ Basic usage:------ >>> all (> 3) []--- True------ >>> all (> 3) [1,2]--- False------ >>> all (> 3) [1,2,3,4,5]--- False------ >>> all (> 3) [1..]--- False------ >>> all (> 3) [4..]--- * Hangs forever *-all :: Foldable t => (a -> Bool) -> t a -> Bool-all p = getAll #. foldMap (All #. p)---- | The largest element of a non-empty structure with respect to the--- given comparison function.------ ==== __Examples__------ Basic usage:------ >>> maximumBy (compare `on` length) ["Hello", "World", "!", "Longest", "bar"]--- "Longest"------ WARNING: This function is partial for possibly-empty structures like lists.---- See Note [maximumBy/minimumBy space usage]-maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a-maximumBy cmp = fromMaybe (errorWithoutStackTrace "maximumBy: empty structure")-  . foldl' max' Nothing-  where-    max' mx y = Just $! case mx of-      Nothing -> y-      Just x -> case cmp x y of-        GT -> x-        _ -> y-{-# INLINEABLE maximumBy #-}---- | The least element of a non-empty structure with respect to the--- given comparison function.------ ==== __Examples__------ Basic usage:------ >>> minimumBy (compare `on` length) ["Hello", "World", "!", "Longest", "bar"]--- "!"------ WARNING: This function is partial for possibly-empty structures like lists.---- See Note [maximumBy/minimumBy space usage]-minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a-minimumBy cmp = fromMaybe (errorWithoutStackTrace "minimumBy: empty structure")-  . foldl' min' Nothing-  where-    min' mx y = Just $! case mx of-      Nothing -> y-      Just x -> case cmp x y of-        GT -> y-        _ -> x-{-# INLINEABLE minimumBy #-}---- | 'notElem' is the negation of 'elem'.------ ==== __Examples__------ Basic usage:------ >>> 3 `notElem` []--- True------ >>> 3 `notElem` [1,2]--- True------ >>> 3 `notElem` [1,2,3,4,5]--- False------ For infinite structures, 'notElem' terminates if the value exists at a--- finite distance from the left side of the structure:------ >>> 3 `notElem` [1..]--- False------ >>> 3 `notElem` ([4..] ++ [3])--- * Hangs forever *-notElem :: (Foldable t, Eq a) => a -> t a -> Bool-notElem x = not . elem x---- | The 'find' function takes a predicate and a structure and returns--- the leftmost element of the structure matching the predicate, or--- 'Nothing' if there is no such element.------ ==== __Examples__------ Basic usage:------ >>> find (> 42) [0, 5..]--- Just 45------ >>> find (> 12) [1..7]--- Nothing-find :: Foldable t => (a -> Bool) -> t a -> Maybe a-find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing))--{--Note [List fusion and continuations in 'c']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we define-  mapM_ f = foldr ((>>) . f) (return ())-(this is the way it used to be).--Now suppose we want to optimise the call--  mapM_ <big> (build g)-    where-  g c n = ...(c x1 y1)...(c x2 y2)....n...--GHC used to proceed like this:--  mapM_ <big> (build g)--  = { Definition of mapM_ }-    foldr ((>>) . <big>) (return ()) (build g)--  = { foldr/build rule }-    g ((>>) . <big>) (return ())--  = { Inline g }-    let c = (>>) . <big>-        n = return ()-    in ...(c x1 y1)...(c x2 y2)....n...--The trouble is that `c`, being big, will not be inlined.  And that can-be absolutely terrible for performance, as we saw in #8763.--It's much better to define--  mapM_ f = foldr c (return ())-    where-      c x k = f x >> k-      {-# INLINE c #-}--Now we get-  mapM_ <big> (build g)--  = { inline mapM_ }-    foldr c (return ()) (build g)-      where c x k = f x >> k-            {-# INLINE c #-}-            f = <big>--Notice that `f` does not inline into the RHS of `c`,-because the INLINE pragma stops it; see-Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils.-Continuing:--  = { foldr/build rule }-    g c (return ())-      where ...-         c x k = f x >> k-         {-# INLINE c #-}-            f = <big>--  = { inline g }-    ...(c x1 y1)...(c x2 y2)....n...-      where c x k = f x >> k-            {-# INLINE c #-}-            f = <big>-            n = return ()--      Now, crucially, `c` does inline--  = { inline c }-    ...(f x1 >> y1)...(f x2 >> y2)....n...-      where f = <big>-            n = return ()--And all is well!  The key thing is that the fragment-`(f x1 >> y1)` is inlined into the body of the builder-`g`.--}--{--Note [maximumBy/minimumBy space usage]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the type signatures of maximumBy and minimumBy were generalized to work-over any Foldable instance (instead of just lists), they were defined using-foldr1.  This was problematic for space usage, as the semantics of maximumBy-and minimumBy essentially require that they examine every element of the-data structure.  Using foldr1 to examine every element results in space usage-proportional to the size of the data structure.  For the common case of lists,-this could be particularly bad (see #10830).--For the common case of lists, switching the implementations of maximumBy and-minimumBy to foldl1 solves the issue, assuming GHC's strictness analysis can then-make these functions only use O(1) stack space.  As of base 4.16, we have-switched to employing foldl' over foldl1, not relying on GHC's optimiser.  See-https://gitlab.haskell.org/ghc/ghc/-/issues/17867 for more context.--}-------------------- $overview------ #overview#--- The Foldable class generalises some common "Data.List" functions to--- structures that can be reduced to a summary value one element at a time.------ == Left and right folds------ #leftright#--- The contribution of each element to the final result is combined with an--- accumulator via a suitable /operator/.  The operator may be explicitly--- provided by the caller as with `foldr` or may be implicit as in `length`.--- In the case of `foldMap`, the caller provides a function mapping each--- element into a suitable 'Monoid', which makes it possible to merge the--- per-element contributions via that monoid's `mappend` function.------ A key distinction is between left-associative and right-associative--- folds:------ * In left-associative folds the accumulator is a partial fold over the---   elements that __precede__ the current element, and is passed to the---   operator as its first (left) argument.  The outermost application of the---   operator merges the contribution of the last element of the structure with---   the contributions of all its predecessors.------ * In right-associative folds the accumulator is a partial fold over the---   elements that __follow__ the current element, and is passed to the---   operator as its second (right) argument.  The outermost application of---   the operator merges the contribution of the first element of the structure---   with the contributions of all its successors.------ These two types of folds are typified by the left-associative strict--- 'foldl'' and the right-associative lazy `foldr`.------ @--- 'foldl'' :: Foldable t => (b -> a -> b) -> b -> t a -> b--- `foldr`  :: Foldable t => (a -> b -> b) -> b -> t a -> b--- @------ Example usage:------ >>> foldl' (+) 0 [1..100]--- 5050--- >>> foldr (&&) True (repeat False)--- False------ The first argument of both is an explicit /operator/ that merges the--- contribution of an element of the structure with a partial fold over,--- respectively, either the preceding or following elements of the structure.------ The second argument of both is an initial accumulator value @z@ of type--- @b@.  This is the result of the fold when the structure is empty.--- When the structure is non-empty, this is the accumulator value merged with--- the first element in left-associative folds, or with the last element in--- right-associative folds.------ The third and final argument is a @Foldable@ structure containing elements--- @(a, b, c, &#x2026;)@.------ * __'foldl''__ takes an operator argument of the form:------     @---     f :: b -- accumulated fold of the initial elements---       -> a -- current element---       -> b -- updated fold, inclusive of current element---     @------     If the structure's last element is @y@, the result of the fold is:------     @---     g y . &#x2026; . g c . g b . g a $ z---       where g element !acc = f acc element---     @------     Since 'foldl'' is strict in the accumulator, this is always---     a [strict](#strict) reduction with no opportunity for early return or---     intermediate results.  The structure must be finite, since no result is---     returned until the last element is processed.  The advantage of---     strictness is space efficiency: the final result can be computed without---     storing a potentially deep stack of lazy intermediate results.------ * __`foldr`__ takes an operator argument of the form:------     @---     f :: a -- current element---       -> b -- accumulated fold of the remaining elements---       -> b -- updated fold, inclusive of current element---     @------     the result of the fold is:------     @f a . f b . f c . &#x2026; $ z@------     If each call of @f@ on the current element @e@, (referenced as @(f e)@---     below) returns a structure in which its second argument is captured in a---     lazily-evaluated component, then the fold of the remaining elements is---     available to the caller of `foldr` as a pending computation (thunk) that---     is computed only when that component is evaluated.------     Alternatively, if any of the @(f e)@ ignore their second argument, the---     fold stops there, with the remaining elements unused.  As a result,---     `foldr` is well suited to define both [corecursive](#corec)---     and [short-circuit](#short) reductions.------     When the operator is always strict in its second argument, 'foldl'' is---     generally a better choice than `foldr`.  When `foldr` is called with a---     strict operator, evaluation cannot begin until the last element is---     reached, by which point a deep stack of pending function applications---     may have been built up in memory.------- $chirality------ #chirality#--- Foldable structures are generally expected to be efficiently iterable from--- left to right. Right-to-left iteration may be substantially more costly, or--- even impossible (as with, for example, infinite lists).  The text in the--- sections that follow that suggests performance differences between--- left-associative and right-associative folds assumes /left-handed/--- structures in which left-to-right iteration is cheaper than right-to-left--- iteration.------ In finite structures for which right-to-left sequencing no less efficient--- than left-to-right sequencing, there is no inherent performance distinction--- between left-associative and right-associative folds.  If the structure's--- @Foldable@ instance takes advantage of this symmetry to also make strict--- right folds space-efficient and lazy left folds corecursive, one need only--- take care to choose either a strict or lazy method for the task at hand.------ Foldable instances for symmetric structures should strive to provide equally--- performant left-associative and right-associative interfaces. The main--- limitations are:------ * The lazy 'fold', 'foldMap' and 'toList' methods have no right-associative---   counterparts.--- * The strict 'foldMap'' method has no left-associative counterpart.------ Thus, for some foldable structures 'foldr'' is just as efficient as 'foldl''--- for strict reduction, and 'foldl' may be just as appropriate for corecursive--- folds as 'foldr'.------ Finally, in some less common structures (e.g. /snoc/ lists) right to left--- iterations are cheaper than left to right.  Such structures are poor--- candidates for a @Foldable@ instance, and are perhaps best handled via their--- type-specific interfaces.  If nevertheless a @Foldable@ instance is--- provided, the material in the sections that follow applies to these also, by--- replacing each method with one with the opposite associativity (when--- available) and switching the order of arguments in the fold's /operator/.------ You may need to pay careful attention to strictness of the fold's /operator/--- when its strictness is different between its first and second argument.--- For example, while @('+')@ is expected to be commutative and strict in both--- arguments, the list concatenation operator @('++')@ is not commutative and--- is only strict in the initial constructor of its first argument.  The fold:------ > myconcat xs = foldr (\a b -> a ++ b) [] xs------ is substantially cheaper (linear in the length of the consumed portion of--- the final list, thus e.g. constant time/space for just the first element)--- than:------ > revconcat xs = foldr (\a b -> b ++ a) [] xs------ In which the total cost scales up with both the number of lists combined and--- the number of elements ultimately consumed.  A more efficient way to combine--- lists in reverse order, is to use:------ > revconcat = foldr (++) [] . reverse-------------------- $reduction------ As observed in the [above description](#leftright) of left and right folds,--- there are three general ways in which a structure can be reduced to a--- summary value:------ * __Recursive__ reduction, which is strict in all the elements of the---   structure.  This produces a single final result only after processing the---   entire input structure, and so the input must be finite.------ * __Corecursion__, which yields intermediate results as it encounters---   additional input elements.  Lazy processing of the remaining elements---   makes the intermediate results available even before the rest of the---   input is processed.  The input may be unbounded, and the caller can---   stop processing intermediate results early.------ * __Short-circuit__ reduction, which examines some initial sequence of the---   input elements, but stops once a termination condition is met, returning a---   final result based only on the elements considered up to that point.  The---   remaining elements are not considered.  The input should generally be---   finite, because the termination condition might otherwise never be met.------ Whether a fold is recursive, corecursive or short-circuiting can depend on--- both the method chosen to perform the fold and on the operator passed to--- that method (which may be implicit, as with the `mappend` method of a monoid--- instance).------ There are also hybrid cases, where the method and/or operator are not well--- suited to the task at hand, resulting in a fold that fails to yield--- incremental results until the entire input is processed, or fails to--- strictly evaluate results as it goes, deferring all the work to the--- evaluation of a large final thunk.  Such cases should be avoided, either by--- selecting a more appropriate @Foldable@ method, or by tailoring the operator--- to the chosen method.------ The distinction between these types of folds is critical, both in deciding--- which @Foldable@ method to use to perform the reduction efficiently, and in--- writing @Foldable@ instances for new structures.  Below is a more detailed--- overview of each type.-------------------- $strict--- #strict#------ Common examples of strict recursive reduction are the various /aggregate/--- functions, like 'sum', 'product', 'length', as well as more complex--- summaries such as frequency counts.  These functions return only a single--- value after processing the entire input structure.  In such cases, lazy--- processing of the tail of the input structure is generally not only--- unnecessary, but also inefficient.  Thus, these and similar folds should be--- implemented in terms of strict left-associative @Foldable@ methods (typically--- 'foldl'') to perform an efficient reduction in constant space.------ Conversely, an implementation of @Foldable@ for a new structure should--- ensure that 'foldl'' actually performs a strict left-associative reduction.------ The 'foldMap'' method is a special case of 'foldl'', in which the initial--- accumulator is `mempty` and the operator is @mappend . f@, where @f@ maps--- each input element into the 'Monoid' in question.  Therefore, 'foldMap'' is--- an appropriate choice under essentially the same conditions as 'foldl'', and--- its implementation for a given @Foldable@ structure should also be a strict--- left-associative reduction.------ While the examples below are not necessarily the most optimal definitions of--- the intended functions, they are all cases in which 'foldMap'' is far more--- appropriate (as well as more efficient) than the lazy `foldMap`.------ > length  = getSum     . foldMap' (const (Sum 1))--- > sum     = getSum     . foldMap' Sum--- > product = getProduct . foldMap' Product------ [ The actual default definitions employ coercions to optimise out---   'getSum' and 'getProduct'. ]-------------------- $strictlist------ The full list of strict recursive functions in this module is:------ * Provided the operator is strict in its left argument:------     @'foldl'' :: Foldable t => (b -> a -> b) -> b -> t a -> b@------ * Provided `mappend` is strict in its left argument:------     @'foldMap'' :: (Foldable t, Monoid m) => (a -> m) -> t a -> m@------ * Provided the instance is correctly defined:------     @---     `length`    :: Foldable t => t a -> Int---     `sum`       :: (Foldable t, Num a) => t a -> a---     `product`   :: (Foldable t, Num a) => t a -> a---     `maximum`   :: (Foldable t, Ord a) => t a -> a---     `minimum`   :: (Foldable t, Ord a) => t a -> a---     `maximumBy` :: Foldable t => (a -> a -> Ordering) -> t a -> a---     `minimumBy` :: Foldable t => (a -> a -> Ordering) -> t a -> a---     @-------------------- $lazy------ #corec#--- Common examples of lazy corecursive reduction are functions that map and--- flatten a structure to a lazy stream of result values, i.e.  an iterator--- over the transformed input elements.  In such cases, it is important to--- choose a @Foldable@ method that is lazy in the tail of the structure, such--- as `foldr` (or `foldMap`, if the result @Monoid@ has a lazy `mappend` as--- with e.g. ByteString Builders).------ Conversely, an implementation of `foldr` for a structure that can--- accommodate a large (and possibly unbounded) number of elements is expected--- to be lazy in the tail of the input, allowing operators that are lazy in the--- accumulator to yield intermediate results incrementally.  Such folds are--- right-associative, with the tail of the stream returned as a lazily--- evaluated component of the result (an element of a tuple or some other--- non-strict constructor, e.g. the @(:)@ constructor for lists).------ The @toList@ function below lazily transforms a @Foldable@ structure to a--- List.  Note that this transformation may be lossy, e.g.  for a keyed--- container (@Map@, @HashMap@, &#x2026;) the output stream holds only the--- values, not the keys.  Lossless transformations to\/from lists of @(key,--- value)@ pairs are typically available in the modules for the specific--- container types.------ > toList = foldr (:) []------ A more complex example is concatenation of a list of lists expressed as a--- nested right fold (bypassing @('++')@).  We can check that the definition is--- indeed lazy by folding an infinite list of lists, and taking an initial--- segment.------ >>> myconcat = foldr (\x z -> foldr (:) z x) []--- >>> take 15 $ myconcat $ map (\i -> [0..i]) [0..]--- [0,0,1,0,1,2,0,1,2,3,0,1,2,3,4]------ Of course in this case another way to achieve the same result is via a--- list comprehension:------ > myconcat xss = [x | xs <- xss, x <- xs]-------------------- $lazylist------ The full list of lazy corecursive functions in this module is:------ * Provided the reduction function is lazy in its second argument,---   (otherwise best to use a strict recursive reduction):------     @---     `foldr`  :: Foldable t => (a -> b -> b) -> b -> t a -> b---     `foldr1` :: Foldable t => (a -> a -> a) -> t a -> a---     @------ * Provided the 'Monoid' `mappend` is lazy in its second argument---   (otherwise best to use a strict recursive reduction):------     @---     `fold`    :: Foldable t => Monoid m => t m -> m---     `foldMap` :: Foldable t => Monoid m => (a -> m) -> t a -> m---     @------ * Provided the instance is correctly defined:------     @---     `toList`    :: Foldable t => t a -> [a]---     `concat`    :: Foldable t => t [a] -> [a]---     `concatMap` :: Foldable t => (a -> [b]) -> t a -> [b]---     @-------------------- $shortcircuit------ #short#--- Examples of short-circuit reduction include various boolean predicates that--- test whether some or all the elements of a structure satisfy a given--- condition.  Because these don't necessarily consume the entire list, they--- typically employ `foldr` with an operator that is conditionally strict in--- its second argument.  Once the termination condition is met the second--- argument (tail of the input structure) is ignored.  No result is returned--- until that happens.------ The key distinguishing feature of these folds is /conditional/ strictness--- in the second argument, it is sometimes evaluated and sometimes not.------ The simplest (degenerate case) of these is 'null', which determines whether--- a structure is empty or not.  This only needs to look at the first element,--- and only to the extent of whether it exists or not, and not its value.  In--- this case termination is guaranteed, and infinite input structures are fine.--- Its default definition is of course in terms of the lazy 'foldr':------ > null = foldr (\_ _ -> False) True------ A more general example is `any`, which applies a predicate to each input--- element in turn until it finds the first one for which the predicate is--- true, at which point it returns success.  If, in an infinite input stream--- the predicate is false for all the elements, `any` will not terminate,--- but since it runs in constant space, it typically won't run out of memory,--- it'll just loop forever.-------------------- $shortlist------ The full list of short-circuit folds in this module is:------ * Boolean predicate folds.---   These functions examine elements strictly until a condition is met,---   but then return a result ignoring the rest (lazy in the tail).  These---   may loop forever given an unbounded input where no elements satisfy the---   termination condition.------     @---     `null`    :: Foldable t => t a -> Bool---     `elem`    :: Foldable t => Eq a => a -> t a -> Bool---     `notElem` :: (Foldable t, Eq a) => a -> t a -> Bool---     `and`     :: Foldable t => t Bool -> Bool---     `or`      :: Foldable t => t Bool -> Bool---     `find`    :: Foldable t => (a -> Bool) -> t a -> Maybe a---     `any`     :: Foldable t => (a -> Bool) -> t a -> Bool---     `all`     :: Foldable t => (a -> Bool) -> t a -> Bool---     @------ * Many instances of @('<|>')@ (e.g. the 'Maybe' instance) are conditionally---   lazy, and use or don't use their second argument depending on the value---   of the first.  These are used with the folds below, which terminate as---   early as possible, but otherwise generally keep going.  Some instances---   (e.g. for List) are always strict, but the result is lazy in the tail---   of the output, so that `asum` for a list of lists is in fact corecursive.---   These folds are defined in terms of `foldr`.------     @---     `asum` :: (Foldable t, Alternative f) => t (f a) -> f a---     `msum` :: (Foldable t, MonadPlus m) => t (m a) -> m a---     @------ * Likewise, the @('*>')@ operator in some `Applicative` functors, and @('>>')@---   in some monads are conditionally lazy and can /short-circuit/ a chain of---   computations.  The below folds will terminate as early as possible, but---   even infinite loops can be productive here, when evaluated solely for---   their stream of IO side-effects.  See "Data.Traversable#effectful"---   for discussion of related functions.------     @---     `traverse_`  :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()---     `for_`       :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()---     `sequenceA_` :: (Foldable t, Applicative f) => t (f a) -> f ()---     `mapM_`      :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()---     `forM_`      :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()---     `sequence_`  :: (Foldable t, Monad m) => t (m a) -> m ()---     @------ * Finally, there's one more special case, `foldlM`:------     @`foldlM` :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b@------     The sequencing of monadic effects proceeds from left to right.  If at---     some step the bind operator @('>>=')@ short-circuits (as with, e.g.,---     'mzero' with a 'MonadPlus', or an exception with a 'MonadThrow', etc.),---     then the evaluated effects will be from an initial portion of the---     element sequence.------     >>> :set -XBangPatterns---     >>> import Control.Monad---     >>> import Control.Monad.Trans.Class---     >>> import Control.Monad.Trans.Maybe---     >>> import Data.Foldable---     >>> let f !_ e = when (e > 3) mzero >> lift (print e)---     >>> runMaybeT $ foldlM f () [0..]---     0---     1---     2---     3---     Nothing------     Contrast this with `foldrM`, which sequences monadic effects from right---     to left, and therefore diverges when folding an unbounded input---     structure without ever having the opportunity to short-circuit.------     >>> let f e _ = when (e > 3) mzero >> lift (print e)---     >>> runMaybeT $ foldrM f () [0..]---     ...hangs...------     When the structure is finite `foldrM` performs the monadic effects from---     right to left, possibly short-circuiting after processing a tail portion---     of the element sequence.------     >>> let f e _ = when (e < 3) mzero >> lift (print e)---     >>> runMaybeT $ foldrM f () [0..5]---     5---     4---     3---     Nothing-------------------- $hybrid------ The below folds, are neither strict reductions that produce a final answer--- in constant space, nor lazy corecursions, and so have limited applicability.--- They do have specialised uses, but are best avoided when in doubt.------ @--- 'foldr'' :: Foldable t => (a -> b -> b) -> b -> t a -> b--- 'foldl'  :: Foldable t => (b -> a -> b) -> b -> t a -> b--- 'foldl1' :: Foldable t => (a -> a -> a) -> t a -> a--- 'foldrM' :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b--- @------ The lazy left-folds (used corecursively) and 'foldrM' (used to sequence--- actions right-to-left) can be performant in structures whose @Foldable@--- instances take advantage of efficient right-to-left iteration to compute--- lazy left folds outside-in from the rightmost element.------ The strict 'foldr'' is the least likely to be useful, structures that--- support efficient sequencing /only/ right-to-left are not common.-------------------- $instances------ #instances#--- For many structures reasonably efficient @Foldable@ instances can be derived--- automatically, by enabling the @DeriveFoldable@ GHC extension.  When this--- works, it is generally not necessary to define a custom instance by hand.--- Though in some cases one may be able to get slightly faster hand-tuned code,--- care is required to avoid producing slower code, or code that is not--- sufficiently lazy, strict or /lawful/.------ The hand-crafted instances can get away with only defining one of 'foldr' or--- 'foldMap'.  All the other methods have default definitions in terms of one--- of these.  The default definitions have the expected strictness and the--- expected asymptotic runtime and space costs, modulo small constant factors.--- If you choose to hand-tune, benchmarking is advised to see whether you're--- doing better than the default derived implementations, plus careful tests to--- ensure that the custom methods are correct.------ Below we construct a @Foldable@ instance for a data type representing a--- (finite) binary tree with depth-first traversal.------ > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)------ a suitable instance would be:------ > instance Foldable Tree where--- >    foldr f z Empty = z--- >    foldr f z (Leaf x) = f x z--- >    foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l------ The 'Node' case is a right fold of the left subtree whose initial--- value is a right fold of the rest of the tree.------ For example, when @f@ is @(':')@, all three cases return an immediate value,--- respectively @z@ or a /cons cell/ holding @x@ or @l@, with the remainder the--- structure, if any, encapsulated in a lazy thunk.  This meets the expected--- efficient [corecursive](#corec) behaviour of 'foldr'.------ Alternatively, one could define @foldMap@:------ > instance Foldable Tree where--- >    foldMap f Empty = mempty--- >    foldMap f (Leaf x) = f x--- >    foldMap f (Node l k r) = foldMap f l <> f k <> foldMap f r------ And indeed some efficiency may be gained by directly defining both,--- avoiding some indirection in the default definitions that express--- one in terms of the other.  If you implement just one, likely 'foldr'--- is the better choice.------ A binary tree typically (when balanced, or randomly biased) provides equally--- efficient access to its left and right subtrees.  This makes it possible to--- define a `foldl` optimised for [corecursive](#corec) folds with operators--- that are lazy in their first (left) argument.------ > instance Foldable Tree where--- >    foldr f z Empty = z--- >    foldr f z (Leaf x) = f x z--- >    foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l--- >    ----- >    foldMap f Empty = mempty--- >    foldMap f (Leaf x) = f x--- >    foldMap f (Node l k r) = foldMap f l <> f k <> foldMap f r--- >    ----- >    foldl f z Empty = z--- >    foldl f z (Leaf x) = f z x--- >    foldl f z (Node l k r) = foldl f (f (foldl f z l) k) r------ Now left-to-right and right-to-left iteration over the structure--- elements are equally efficient (note the mirror-order output when--- using `foldl`):------ >>> foldr (\e acc -> e : acc) [] (Node (Leaf 1) 2 (Leaf 3))--- [1,2,3]--- >>> foldl (\acc e -> e : acc) [] (Node (Leaf 1) 2 (Leaf 3))--- [3,2,1]------ We can carry this further, and define more non-default methods...------ The structure definition actually admits trees that are unbounded on either--- or both sides.  The only fold that can plausibly terminate for a tree--- unbounded on both left and right is `null`, when defined as shown below.--- The default definition in terms of `foldr` diverges if the tree is unbounded--- on the left.  Here we define a variant that avoids travelling down the tree--- to find the leftmost element and just examines the root node.------ >    null Empty = True--- >    null _     = False------ This is a sound choice also for finite trees.------ In practice, unbounded trees are quite uncommon, and can barely be said to--- be @Foldable@.  They would typically employ breadth first traversal, and--- would support only corecursive and short-circuit folds (diverge under strict--- reduction).------ Returning to simpler instances, defined just in terms of `foldr`, it is--- somewhat surprising that a fairly efficient /default/ implementation of the--- strict 'foldl'' is defined in terms of lazy `foldr` when only the latter is--- explicitly provided by the instance.  It may be instructive to take a look--- at how this works.-------------------- $strictlazy------ #strictlazy#------ Sometimes, it is useful for the result of applying 'foldr' to be a--- /function/.  This is done by mapping the structure elements to functions--- with the same argument and result types.  The per-element functions are then--- composed to give the final result.------ For example, we can /flip/ the strict left fold 'foldl'' by writing:------ > foldl' f z xs = flippedFoldl' f xs z------ with the function 'flippedFoldl'' defined as below, with 'seq' used to--- ensure the strictness in the accumulator:------ > flippedFoldl' f [] z = z--- > flippedFoldl' f (x : xs) z = z `seq` flippedFoldl' f xs (f z x)------ Rewriting to use lambdas, this is:------ > flippedFoldl' f [] = \ b -> b--- > flippedFoldl' f (x : xs) = \ b -> b `seq` r (f b x)--- >     where r = flippedFoldl' f xs------ The above has the form of a right fold, enabling a rewrite to:------ > flippedFoldl' f = \ xs -> foldr f' id xs--- >     where f' x r = \ b -> b `seq` r (f b x)------ We can now unflip this to get 'foldl'':------ > foldl' f z = \ xs -> foldr f' id xs z--- >           -- \ xs -> flippedFoldl' f xs z--- >   where f' x r = \ b -> b `seq` r (f b x)------ The function __@foldr f' id xs@__ applied to @z@ is built corecursively, and--- its terms are applied to an eagerly evaluated accumulator before further--- terms are applied to the result.  As required, this runs in constant space,--- and can be optimised to an efficient loop.------ (The actual definition of 'foldl'' labels the lambdas in the definition of--- __@f'@__ above as /oneShot/, which enables further optimisations).-------------------- $generative------ #generative#--- So far, we have not discussed /generative recursion/.  Unlike recursive--- reduction or corecursion, instead of processing a sequence of elements--- already in memory, generative recursion involves producing a possibly--- unbounded sequence of values from an initial seed value.  The canonical--- example of this is 'Data.List.unfoldr' for Lists, with variants available--- for Vectors and various other structures.------ A key issue with lists, when used generatively as /iterators/, rather than as--- poor-man's containers (see [[1\]](#uselistsnot)), is that such iterators--- tend to consume memory when used more than once.  A single traversal of a--- list-as-iterator will run in constant space, but as soon as the list is--- retained for reuse, its entire element sequence is stored in memory, and the--- second traversal reads the copy, rather than regenerates the elements.  It--- is sometimes better to recompute the elements rather than memoise the list.------ Memoisation happens because the built-in Haskell list __@[]@__ is--- represented as __data__, either empty or a /cons-cell/ holding the first--- element and the tail of the list.  The @Foldable@ class enables a variant--- representation of iterators as /functions/, which take an operator and a--- starting accumulator and output a summary result.------ The [@fmlist@](https://hackage.haskell.org/package/fmlist) package takes--- this approach, by representing a list via its `foldMap` action.------ Below we implement an analogous data structure using a representation--- based on `foldr`.  This is an example of /Church encoding/--- (named after Alonzo Church, inventor of the lambda calculus).------ > {-# LANGUAGE RankNTypes #-}--- > newtype FRList a = FR { unFR :: forall b. (a -> b -> b) -> b -> b }------ The __@unFR@__ field of this type is essentially its `foldr` method--- with the list as its first rather than last argument.  Thus we--- immediately get a @Foldable@ instance (and a 'toList' function--- mapping an __@FRList@__ to a regular list).------ > instance Foldable FRList where--- >     foldr f z l = unFR l f z--- >     -- With older versions of @base@, also define sum, product, ...--- >     -- to ensure use of the strict 'foldl''.--- >     -- sum = foldl' (+) 0--- >     -- ...------ We can convert a regular list to an __@FRList@__ with:------ > fromList :: [a] -> FRList a--- > fromList as = FRList $ \ f z -> foldr f z as------ However, reuse of an __@FRList@__ obtained in this way will typically--- memoise the underlying element sequence.  Instead, we can define--- __@FRList@__ terms directly:------ > -- | Immediately return the initial accumulator--- > nil :: FRList a--- > nil = FRList $ \ _ z -> z--- > {-# INLINE nil #-}------ > -- | Fold the tail to use as an accumulator with the new initial element--- > cons :: a -> FRList a -> FRList a--- > cons a l = FRList $ \ f z -> f a (unFR l f z)--- > {-# INLINE cons #-}------ More crucially, we can also directly define the key building block for--- generative recursion:------ > -- | Generative recursion, dual to `foldr`.--- > unfoldr :: (s -> Maybe (a, s)) -> s -> FRList a--- > unfoldr g s0 = FR generate--- >   where generate f z = loop s0--- >           where loop s | Just (a, t) <- g s = f a (loop t)--- >                        | otherwise = z--- > {-# INLINE unfoldr #-}------ Which can, for example, be specialised to number ranges:------ > -- | Generate a range of consecutive integral values.--- > range :: (Ord a, Integral a) => a -> a -> FRList a--- > range lo hi =--- >     unfoldr (\s -> if s > hi then Nothing else Just (s, s+1)) lo--- > {-# INLINE range #-}------ The program below, when compiled with optimisation:------ > main :: IO ()--- > main = do--- >     let r :: FRList Int--- >         r = range 1 10000000--- >      in print (sum r, length r)------ produces the expected output with no noticeable garbage-collection, despite--- reuse of the __@FRList@__ term __@r@__.------ > (50000005000000,10000000)--- >     52,120 bytes allocated in the heap--- >      3,320 bytes copied during GC--- >     44,376 bytes maximum residency (1 sample(s))--- >     25,256 bytes maximum slop--- >          3 MiB total memory in use (0 MB lost due to fragmentation)------ The Weak Head Normal Form of an __@FRList@__ is a lambda abstraction not a--- data value, and reuse does not lead to memoisation.  Reuse of the iterator--- above is somewhat contrived, when computing multiple folds over a common--- list, you should generally traverse a  list only [once](#multipass).  The--- goal is to demonstrate that the separate computations of the 'sum' and--- 'length' run efficiently in constant space, despite reuse.  This would not--- be the case with the list @[1..10000000]@.------ This is, however, an artificially simple reduction.  More typically, there--- are likely to be some allocations in the inner loop, but the temporary--- storage used will be garbage-collected as needed, and overall memory--- utilisation will remain modest and will not scale with the size of the list.------ If we go back to built-in lists (i.e. __@[]@__), but avoid reuse by--- performing reduction in a single pass, as below:------ > data PairS a b = P !a !b -- We define a strict pair datatype--- >--- > main :: IO ()--- > main = do--- >     let l :: [Int]--- >         l = [1..10000000]--- >      in print $ average l--- >   where--- >     sumlen :: PairS Int Int -> Int -> PairS Int Int--- >     sumlen (P s l) a = P (s + a) (l + 1)--- >--- >     average is =--- >         let (P s l) = foldl' sumlen (P 0 0) is--- >          in (fromIntegral s :: Double) / fromIntegral l------ the result is again obtained in constant space:------ > 5000000.5--- >          102,176 bytes allocated in the heap--- >            3,320 bytes copied during GC--- >           44,376 bytes maximum residency (1 sample(s))--- >           25,256 bytes maximum slop--- >                3 MiB total memory in use (0 MB lost due to fragmentation)------ (and, in fact, faster than with __@FRList@__ by a small factor).------ The __@[]@__ list structure works as an efficient iterator when used--- just once.  When space-leaks via list reuse are not a concern, and/or--- memoisation is actually desirable, the regular list implementation is--- likely to be faster.  This is not a suggestion to replace all your uses of--- __@[]@__ with a generative alternative.------ The __@FRList@__ type could be further extended with instances of 'Functor',--- 'Applicative', 'Monad', 'Alternative', etc., and could then provide a--- fully-featured list type, optimised for reuse without space-leaks.  If,--- however, all that's required is space-efficient, re-use friendly iteration,--- less is perhaps more, and just @Foldable@ may be sufficient.-------------------- $multipass------ #multipass#--- In applications where you want to compute a composite function of a--- structure, which requires more than one aggregate as an input, it is--- generally best to compute all the aggregates in a single pass, rather--- than to traverse the same structure repeatedly.------ The [@foldl@](http://hackage.haskell.org/package/foldl) package implements a--- robust general framework for dealing with this situation.  If you choose to--- to do it yourself, with a bit of care, the simplest cases are not difficult--- to handle directly.  You just need to accumulate the individual aggregates--- as __strict__ components of a single data type, and then apply a final--- transformation to it to extract the composite result.  For example,--- computing an average requires computing both the 'sum' and the 'length' of a--- (non-empty) structure and dividing the sum by the length:------ > import Data.Foldable (foldl')--- >--- > data PairS a b = P !a !b -- We define a strict pair datatype--- >--- > -- | Compute sum and length in a single pass, then reduce to the average.--- > average :: (Foldable f, Fractional a) => f a -> a--- > average xs =--- >     let sumlen (P s l) a = P (s + a) (l + 1 :: Int)--- >         (P s l) = foldl' sumlen (P 0 0) xs--- >      in s / fromIntegral l------ The above example is somewhat contrived, some structures keep track of their--- length internally, and can return it in \(\mathcal{O}(1)\) time, so this--- particular recipe for averages is not always the most efficient.  In--- general, composite aggregate functions of large structures benefit from--- single-pass reduction.  This is especially the case when reuse of a list and--- memoisation of its elements is thereby avoided,-------------------- $laws--- #laws#------ The type constructor 'Endo' from "Data.Monoid", associates with each type--- __@b@__ the __@newtype@__-encapsulated type of functions mapping __@b@__ to--- itself.  Functions from a type to itself are called /endomorphisms/, hence--- the name /Endo/.  The type __@Endo b@__ is a 'Monoid' under function--- composition:------ > newtype Endo b = Endo { appEndo :: b -> b }--- > instance Semigroup Endo b where--- >     Endo f <> Endo g = Endo (f . g)--- > instance Monoid Endo b where--- >     mempty = Endo id------ For every 'Monoid' m, we also have a 'Dual' monoid __@Dual m@__ which--- combines elements in the opposite order:------ > newtype Dual m = Dual { getDual :: m }--- > instance Semigroup m => Semigroup Dual m where--- >     Dual a <> Dual b = Dual (b <> a)--- > instance Monoid m => Monoid Dual m where--- >     mempty = Dual mempty------ With the above preliminaries out of the way, 'Foldable' instances are--- expected to satisfy the following laws:------ The 'foldr' method must be equivalent in value and strictness to replacing--- each element __@a@__ of a 'Foldable' structure with __@Endo (f a)@__,--- composing these via 'foldMap' and applying the result to the base case--- __@z@__:------ > foldr f z t = appEndo (foldMap (Endo . f) t ) z------ Likewise, the 'foldl' method must be equivalent in value and strictness--- to composing the functions __@flip f a@__ in reverse order and applying--- the result to the base case:------ > foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z------ When the elements of the structure are taken from a 'Monoid', the--- definition of 'fold' must agree with __@foldMap id@__:------ > fold = foldMap id------ The 'length' method must agree with a 'foldMap' mapping each element to--- __@Sum 1@__ (The 'Sum' type abstracts numbers as a monoid under addition).------ > length = getSum . foldMap (Sum . const 1)------ @sum@, @product@, @maximum@, and @minimum@ should all be essentially--- equivalent to @foldMap@ forms, such as------ > sum     = getSum     . foldMap' Sum--- > product = getProduct . foldMap' Product------ but are generally more efficient when defined more directly as:------ > sum = foldl' (+) 0--- > product = foldl' (*) 1------ If the 'Foldable' structure has a 'Functor' instance, then for every--- function __@f@__ mapping the elements into a 'Monoid', it should satisfy:------ > foldMap f = fold . fmap f------ which implies that------ > foldMap f . fmap g = foldMap (f . g)----------------------- $notes------ #notes#--- Since 'Foldable' does not have 'Functor' as a superclass, it is possible to--- define 'Foldable' instances for structures that constrain their element--- types.  Therefore, __@Set@__ can be 'Foldable', even though sets keep their--- elements in ascending order.  This requires the elements to be comparable,--- which precludes defining a 'Functor' instance for @Set@.------ The 'Foldable' class makes it possible to use idioms familiar from the @List@--- type with container structures that are better suited to the task at hand.--- This supports use of more appropriate 'Foldable' data types, such as @Seq@,--- @Set@, @NonEmpty@, etc., without requiring new idioms (see--- [[1\]](#uselistsnot) for when not to use lists).------ The more general methods of the 'Foldable' class are now exported by the--- "Prelude" in place of the original List-specific methods (see the--- [FTP Proposal](https://wiki.haskell.org/Foldable_Traversable_In_Prelude)).--- The List-specific variants are for now still available in "GHC.OldList", but--- that module is intended only as a transitional aid, and may be removed in--- the future.------ Surprises can arise from the @Foldable@ instance of the 2-tuple @(a,)@ which--- now behaves as a 1-element @Foldable@ container in its second slot.  In--- contexts where a specific monomorphic type is expected, and you want to be--- able to rely on type errors to guide refactoring, it may make sense to--- define and use less-polymorphic variants of some of the @Foldable@ methods.------ Below are two examples showing a definition of a reusable less-polymorphic--- 'sum' and a one-off in-line specialisation of 'length':------ > {-# LANGUAGE TypeApplications #-}--- >--- > mySum :: Num a => [a] -> a--- > mySum = sum--- >--- > type SlowVector a = [a]--- > slowLength :: SlowVector -> Int--- > slowLength v = length @[] v------ In both cases, if the data type to which the function is applied changes--- to something other than a list, the call-site will no longer compile until--- appropriate changes are made.---- $linear------ It is perhaps worth noting that since the __`elem`__ function in the--- Foldable class carries only an __`Eq`__ constraint on the element type,--- search for the presence or absence of an element in the structure generally--- takes \(\mathcal{O}(n)\) time, even for ordered structures like __@Set@__--- that are potentially capable of performing the search faster.  (The @member@--- function of the @Set@ module carries an `Ord` constraint, and can perform--- the search in \(\mathcal{O}(log\ n)\) time).------ An alternative to Foldable's __`elem`__ method is required in order to--- abstract potentially faster than linear search over general container--- structures.  This can be achieved by defining an additional type class (e.g.--- @HasMember@ below).  Instances of such a type class (that are also--- `Foldable') can employ the `elem` linear search as a last resort, when--- faster search is not supported.------ > {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--- >--- > import qualified Data.Set as Set--- >--- > class Eq a => HasMember t a where--- >     member :: a -> t a -> Bool--- >--- > instance Eq a => HasMember [] a where--- >     member = elem--- > [...]--- > instance Ord a => HasMember Set.Set a where--- >     member = Set.member------ The above suggests that 'elem' may be a misfit in the 'Foldable' class.--- Alternative design ideas are solicited on GHC's bug tracker via issue--- [\#20421](https://gitlab.haskell.org/ghc/ghc/-/issues/20421).------ Note that some structure-specific optimisations may of course be possible--- directly in the corresponding @Foldable@ instance, e.g. with @Set@ the size--- of the set is known in advance, without iterating to count the elements, and--- its `length` instance takes advantage of this to return the size directly.-------------------- $also------  * [1] #uselistsnot# \"When You Should Use Lists in Haskell (Mostly, You Should Not)\",---    by Johannes Waldmann,---    in arxiv.org, Programming Languages (cs.PL), at---    <https://arxiv.org/abs/1808.08329>.------  * [2] \"The Essence of the Iterator Pattern\",---    by Jeremy Gibbons and Bruno Oliveira,---    in /Mathematically-Structured Functional Programming/, 2006, online at---    <http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/#iterator>.------  * [3] \"A tutorial on the universality and expressiveness of fold\",---    by Graham Hutton, J\. Functional Programming 9 (4): 355–372, July 1999,---    online at <http://www.cs.nott.ac.uk/~pszgmh/fold.pdf>.
− Data/Function.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Function--- Copyright   :  Nils Anders Danielsson 2006---             ,  Alexander Berntsen     2014--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Simple combinators working solely on and with functions.-----------------------------------------------------------------------------------module Data.Function-  ( -- * "Prelude" re-exports-    id, const, (.), flip, ($)-    -- * Other combinators-  , (&)-  , fix-  , on-  ) where--import GHC.Base ( ($), (.), id, const, flip )--infixl 0 `on`-infixl 1 &---- | @'fix' f@ is the least fixed point of the function @f@,--- i.e. the least defined @x@ such that @f x = x@.------ For example, we can write the factorial function using direct recursion as------ >>> let fac n = if n <= 1 then 1 else n * fac (n-1) in fac 5--- 120------ This uses the fact that Haskell’s @let@ introduces recursive bindings. We can--- rewrite this definition using 'fix',------ >>> fix (\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5--- 120------ Instead of making a recursive call, we introduce a dummy parameter @rec@;--- when used within 'fix', this parameter then refers to 'fix'’s argument, hence--- the recursion is reintroduced.-fix :: (a -> a) -> a-fix f = let x = f x in x---- | @'on' b u x y@ runs the binary function @b@ /on/ the results of applying--- unary function @u@ to two arguments @x@ and @y@. From the opposite--- perspective, it transforms two inputs and combines the outputs.------ @((+) \``on`\` f) x y = f x + f y@------ Typical usage: @'Data.List.sortBy' ('Prelude.compare' \`on\` 'Prelude.fst')@.------ Algebraic properties:------ * @(*) \`on\` 'id' = (*) -- (if (*) &#x2209; {&#x22a5;, 'const' &#x22a5;})@------ * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@------ * @'flip' on f . 'flip' on g = 'flip' on (g . f)@-on :: (b -> b -> c) -> (a -> b) -> a -> a -> c-(.*.) `on` f = \x y -> f x .*. f y--- Proofs (so that I don't have to edit the test-suite):----   (*) `on` id--- =---   \x y -> id x * id y--- =---   \x y -> x * y--- = { If (*) /= _|_ or const _|_. }---   (*)----   (*) `on` f `on` g--- =---   ((*) `on` f) `on` g--- =---   \x y -> ((*) `on` f) (g x) (g y)--- =---   \x y -> (\x y -> f x * f y) (g x) (g y)--- =---   \x y -> f (g x) * f (g y)--- =---   \x y -> (f . g) x * (f . g) y--- =---   (*) `on` (f . g)--- =---   (*) `on` f . g----   flip on f . flip on g--- =---   (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g--- =---   (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g)--- =---   \(*) -> (*) `on` g `on` f--- = { See above. }---   \(*) -> (*) `on` g . f--- =---   (\h (*) -> (*) `on` h) (g . f)--- =---   flip on (g . f)----- | '&' is a reverse application operator.  This provides notational--- convenience.  Its precedence is one higher than that of the forward--- application operator '$', which allows '&' to be nested in '$'.------ >>> 5 & (+1) & show--- "6"------ @since 4.8.0.0-(&) :: a -> (a -> b) -> b-x & f = f x---- $setup--- >>> import Prelude
− Data/Functor.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Functor--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable--------- A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@,--- lets you apply any function of type @(a -> b)@ to turn an @f a@ into an @f b@, preserving the--- structure of @f@.------ ==== __Examples__------  >>> fmap show (Just 1)  --  (a   -> b)      -> f a       -> f b---  Just "1"                --  (Int -> String) -> Maybe Int -> Maybe String------  >>> fmap show Nothing   --  (a   -> b)      -> f a       -> f b---  Nothing                 --  (Int -> String) -> Maybe Int -> Maybe String------  >>> fmap show [1,2,3]   --  (a   -> b)      -> f a       -> f b---  ["1","2","3"]           --  (Int -> String) -> [Int]     -> [String]------  >>> fmap show []        --  (a   -> b)      -> f a       -> f b---  []                      --  (Int -> String) -> [Int]     -> [String]------ The 'fmap' function is also available as the infix operator '<$>':------  >>> fmap show (Just 1) --  (Int -> String) -> Maybe Int -> Maybe String---  Just "1"---  >>> show <$> (Just 1)  --  (Int -> String) -> Maybe Int -> Maybe String---  Just "1"--module Data.Functor-    (-      Functor(..),-      ($>),-      (<$>),-      (<&>),-      void,-    ) where--import GHC.Base ( Functor(..), flip )---- $setup--- Allow the use of Prelude in doctests.--- >>> import Prelude hiding ((<$>))--infixl 4 <$>---- | An infix synonym for 'fmap'.------ The name of this operator is an allusion to 'Prelude.$'.--- Note the similarities between their types:------ >  ($)  ::              (a -> b) ->   a ->   b--- > (<$>) :: Functor f => (a -> b) -> f a -> f b------ Whereas 'Prelude.$' is function application, '<$>' is function--- application lifted over a 'Functor'.------ ==== __Examples__------ Convert from a @'Data.Maybe.Maybe' 'Data.Int.Int'@ to a @'Data.Maybe.Maybe'--- 'Data.String.String'@ using 'Prelude.show':------ >>> show <$> Nothing--- Nothing--- >>> show <$> Just 3--- Just "3"------ Convert from an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ to an--- @'Data.Either.Either' 'Data.Int.Int'@ 'Data.String.String' using 'Prelude.show':------ >>> show <$> Left 17--- Left 17--- >>> show <$> Right 17--- Right "17"------ Double each element of a list:------ >>> (*2) <$> [1,2,3]--- [2,4,6]------ Apply 'Prelude.even' to the second element of a pair:------ >>> even <$> (2,2)--- (2,True)----(<$>) :: Functor f => (a -> b) -> f a -> f b-(<$>) = fmap--infixl 1 <&>---- | Flipped version of '<$>'.------ @--- ('<&>') = 'flip' 'fmap'--- @------ @since 4.11.0.0------ ==== __Examples__--- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right':------ >>> Just 2 <&> (+1)--- Just 3------ >>> [1,2,3] <&> (+1)--- [2,3,4]------ >>> Right 3 <&> (+1)--- Right 4----(<&>) :: Functor f => f a -> (a -> b) -> f b-as <&> f = f <$> as--infixl 4 $>---- | Flipped version of '<$'.------ @since 4.7.0.0------ ==== __Examples__------ Replace the contents of a @'Data.Maybe.Maybe' 'Data.Int.Int'@ with a constant--- 'Data.String.String':------ >>> Nothing $> "foo"--- Nothing--- >>> Just 90210 $> "foo"--- Just "foo"------ Replace the contents of an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@--- with a constant 'Data.String.String', resulting in an @'Data.Either.Either'--- 'Data.Int.Int' 'Data.String.String'@:------ >>> Left 8675309 $> "foo"--- Left 8675309--- >>> Right 8675309 $> "foo"--- Right "foo"------ Replace each element of a list with a constant 'Data.String.String':------ >>> [1,2,3] $> "foo"--- ["foo","foo","foo"]------ Replace the second element of a pair with a constant 'Data.String.String':------ >>> (1,2) $> "foo"--- (1,"foo")----($>) :: Functor f => f a -> b -> f b-($>) = flip (<$)---- | @'void' value@ discards or ignores the result of evaluation, such--- as the return value of an 'System.IO.IO' action.------ ==== __Examples__------ Replace the contents of a @'Data.Maybe.Maybe' 'Data.Int.Int'@ with unit:------ >>> void Nothing--- Nothing--- >>> void (Just 3)--- Just ()------ Replace the contents of an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@--- with unit, resulting in an @'Data.Either.Either' 'Data.Int.Int' '()'@:------ >>> void (Left 8675309)--- Left 8675309--- >>> void (Right 8675309)--- Right ()------ Replace every element of a list with unit:------ >>> void [1,2,3]--- [(),(),()]------ Replace the second element of a pair with unit:------ >>> void (1,2)--- (1,())------ Discard the result of an 'System.IO.IO' action:------ >>> mapM print [1,2]--- 1--- 2--- [(),()]--- >>> void $ mapM print [1,2]--- 1--- 2----void :: Functor f => f a -> f ()-void x = () <$ x
− Data/Functor/Classes.hs 
@@ -1,1045 +0,0 @@-{-# 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--- >   readPrec     = readPrec1--- >   readListPrec = readListPrecDefault--- > 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, readPrec1,-    liftReadListDefault, liftReadListPrecDefault,-    Show1(..), showsPrec1,-    -- ** For binary constructors-    Eq2(..), eq2,-    Ord2(..), compare2,-    Read2(..), readsPrec2, readPrec2,-    liftReadList2Default, liftReadListPrec2Default,-    Show2(..), showsPrec2,-    -- * Helper functions-    -- $example-    readsData, readData,-    readsUnaryWith, readUnaryWith,-    readsBinaryWith, readBinaryWith,-    showsUnaryWith,-    showsBinaryWith,-    -- ** Obsolete helpers-    readsUnary,-    readsUnary1,-    readsBinary1,-    showsUnary,-    showsUnary1,-    showsBinary1,-  ) where--import Control.Applicative (Alternative((<|>)), Const(Const))--import Data.Functor.Identity (Identity(Identity))-import Data.Proxy (Proxy(Proxy))-import Data.List.NonEmpty (NonEmpty(..))-import Data.Ord (Down(Down))-import Data.Complex (Complex((:+)))--import GHC.Tuple (Solo (..))-import GHC.Read (expectP, list, paren)--import Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec)-import Text.Read (Read(..), parens, prec, step)-import Text.Read.Lex (Lexeme(..))-import Text.Show (showListWith)---- $setup--- >>> import Prelude--- >>> import Data.Complex (Complex (..))--- >>> import Text.ParserCombinators.ReadPrec---- | Lifting of the 'Eq' class to unary type constructors.------ @since 4.9.0.0-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.-    ---    -- @since 4.9.0.0-    liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool---- | Lift the standard @('==')@ function through the type constructor.------ @since 4.9.0.0-eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool-eq1 = liftEq (==)---- | Lifting of the 'Ord' class to unary type constructors.------ @since 4.9.0.0-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.-    ---    -- @since 4.9.0.0-    liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering---- | Lift the standard 'compare' function through the type constructor.------ @since 4.9.0.0-compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering-compare1 = liftCompare compare---- | Lifting of the 'Read' class to unary type constructors.------ Both 'liftReadsPrec' and 'liftReadPrec' exist to match the interface--- provided in the 'Read' type class, but it is recommended to implement--- 'Read1' instances using 'liftReadPrec' as opposed to 'liftReadsPrec', since--- the former is more efficient than the latter. For example:------ @--- instance 'Read1' T where---   'liftReadPrec'     = ...---   'liftReadListPrec' = 'liftReadListPrecDefault'--- @------ For more information, refer to the documentation for the 'Read' class.------ @since 4.9.0.0-class Read1 f where-    {-# MINIMAL liftReadsPrec | liftReadPrec #-}--    -- | 'readsPrec' function for an application of the type constructor-    -- based on 'readsPrec' and 'readList' functions for the argument type.-    ---    -- @since 4.9.0.0-    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)-    liftReadsPrec rp rl = readPrec_to_S $-        liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))--    -- | '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.-    ---    -- @since 4.9.0.0-    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]-    liftReadList rp rl = readPrec_to_S-        (list $ liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0--    -- | 'readPrec' function for an application of the type constructor-    -- based on 'readPrec' and 'readListPrec' functions for the argument type.-    ---    -- @since 4.10.0.0-    liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)-    liftReadPrec rp rl = readS_to_Prec $-        liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0)--    -- | 'readListPrec' function for an application of the type constructor-    -- based on 'readPrec' and 'readListPrec' functions for the argument type.-    ---    -- The default definition uses 'liftReadList'. Instances that define-    -- 'liftReadPrec' should also define 'liftReadListPrec' as-    -- 'liftReadListPrecDefault'.-    ---    -- @since 4.10.0.0-    liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]-    liftReadListPrec rp rl = readS_to_Prec $ \_ ->-        liftReadList (readPrec_to_S rp) (readPrec_to_S rl 0)---- | Lift the standard 'readsPrec' and 'readList' functions through the--- type constructor.------ @since 4.9.0.0-readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)-readsPrec1 = liftReadsPrec readsPrec readList---- | Lift the standard 'readPrec' and 'readListPrec' functions through the--- type constructor.------ @since 4.10.0.0-readPrec1 :: (Read1 f, Read a) => ReadPrec (f a)-readPrec1 = liftReadPrec readPrec readListPrec---- | A possible replacement definition for the 'liftReadList' method.--- This is only needed for 'Read1' instances where 'liftReadListPrec' isn't--- defined as 'liftReadListPrecDefault'.------ @since 4.10.0.0-liftReadListDefault :: Read1 f => (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]-liftReadListDefault rp rl = readPrec_to_S-    (liftReadListPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0---- | A possible replacement definition for the 'liftReadListPrec' method,--- defined using 'liftReadPrec'.------ @since 4.10.0.0-liftReadListPrecDefault :: Read1 f => ReadPrec a -> ReadPrec [a]-                        -> ReadPrec [f a]-liftReadListPrecDefault rp rl = list (liftReadPrec rp rl)---- | Lifting of the 'Show' class to unary type constructors.------ @since 4.9.0.0-class Show1 f where-    -- | 'showsPrec' function for an application of the type constructor-    -- based on 'showsPrec' and 'showList' functions for the argument type.-    ---    -- @since 4.9.0.0-    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.-    ---    -- @since 4.9.0.0-    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.------ @since 4.9.0.0-showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS-showsPrec1 = liftShowsPrec showsPrec showList---- | Lifting of the 'Eq' class to binary type constructors.------ @since 4.9.0.0-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.-    ---    -- @since 4.9.0.0-    liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool---- | Lift the standard @('==')@ function through the type constructor.------ @since 4.9.0.0-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.------ @since 4.9.0.0-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.-    ---    -- @since 4.9.0.0-    liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->-        f a c -> f b d -> Ordering---- | Lift the standard 'compare' function through the type constructor.------ @since 4.9.0.0-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.------ Both 'liftReadsPrec2' and 'liftReadPrec2' exist to match the interface--- provided in the 'Read' type class, but it is recommended to implement--- 'Read2' instances using 'liftReadPrec2' as opposed to 'liftReadsPrec2',--- since the former is more efficient than the latter. For example:------ @--- instance 'Read2' T where---   'liftReadPrec2'     = ...---   'liftReadListPrec2' = 'liftReadListPrec2Default'--- @------ For more information, refer to the documentation for the 'Read' class.------ @since 4.9.0.0-class Read2 f where-    {-# MINIMAL liftReadsPrec2 | liftReadPrec2 #-}--    -- | 'readsPrec' function for an application of the type constructor-    -- based on 'readsPrec' and 'readList' functions for the argument types.-    ---    -- @since 4.9.0.0-    liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->-        (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)-    liftReadsPrec2 rp1 rl1 rp2 rl2 = readPrec_to_S $-        liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))-                      (readS_to_Prec rp2) (readS_to_Prec (const rl2))--    -- | '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.-    ---    -- @since 4.9.0.0-    liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->-        (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]-    liftReadList2 rp1 rl1 rp2 rl2 = readPrec_to_S-       (list $ liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))-                             (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0--    -- | 'readPrec' function for an application of the type constructor-    -- based on 'readPrec' and 'readListPrec' functions for the argument types.-    ---    -- @since 4.10.0.0-    liftReadPrec2 :: ReadPrec a -> ReadPrec [a] ->-        ReadPrec b -> ReadPrec [b] -> ReadPrec (f a b)-    liftReadPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $-        liftReadsPrec2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)-                       (readPrec_to_S rp2) (readPrec_to_S rl2 0)--    -- | 'readListPrec' function for an application of the type constructor-    -- based on 'readPrec' and 'readListPrec' functions for the argument types.-    ---    -- The default definition uses 'liftReadList2'. Instances that define-    -- 'liftReadPrec2' should also define 'liftReadListPrec2' as-    -- 'liftReadListPrec2Default'.-    ---    -- @since 4.10.0.0-    liftReadListPrec2 :: ReadPrec a -> ReadPrec [a] ->-        ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]-    liftReadListPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $ \_ ->-        liftReadList2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)-                      (readPrec_to_S rp2) (readPrec_to_S rl2 0)---- | Lift the standard 'readsPrec' function through the type constructor.------ @since 4.9.0.0-readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)-readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList---- | Lift the standard 'readPrec' function through the type constructor.------ @since 4.10.0.0-readPrec2 :: (Read2 f, Read a, Read b) => ReadPrec (f a b)-readPrec2 = liftReadPrec2 readPrec readListPrec readPrec readListPrec---- | A possible replacement definition for the 'liftReadList2' method.--- This is only needed for 'Read2' instances where 'liftReadListPrec2' isn't--- defined as 'liftReadListPrec2Default'.------ @since 4.10.0.0-liftReadList2Default :: Read2 f => (Int -> ReadS a) -> ReadS [a] ->-    (Int -> ReadS b) -> ReadS [b] ->ReadS [f a b]-liftReadList2Default rp1 rl1 rp2 rl2 = readPrec_to_S-    (liftReadListPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))-                       (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0---- | A possible replacement definition for the 'liftReadListPrec2' method,--- defined using 'liftReadPrec2'.------ @since 4.10.0.0-liftReadListPrec2Default :: Read2 f => ReadPrec a -> ReadPrec [a] ->-    ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]-liftReadListPrec2Default rp1 rl1 rp2 rl2 = list (liftReadPrec2 rp1 rl1 rp2 rl2)---- | Lifting of the 'Show' class to binary type constructors.------ @since 4.9.0.0-class Show2 f where-    -- | 'showsPrec' function for an application of the type constructor-    -- based on 'showsPrec' and 'showList' functions for the argument types.-    ---    -- @since 4.9.0.0-    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.-    ---    -- @since 4.9.0.0-    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.------ @since 4.9.0.0-showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS-showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList---- Instances for Prelude type constructors---- | @since 4.9.0.0-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---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance Read1 Maybe where-    liftReadPrec rp _ =-        parens (expectP (Ident "Nothing") *> pure Nothing)-        <|>-        readData (readUnaryWith rp "Just" Just)--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-instance Show1 Maybe where-    liftShowsPrec _ _ _ Nothing = showString "Nothing"-    liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x---- | @since 4.9.0.0-instance Eq1 [] where-    liftEq _ [] [] = True-    liftEq _ [] (_:_) = False-    liftEq _ (_:_) [] = False-    liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys---- | @since 4.9.0.0-instance Ord1 [] where-    liftCompare _ [] [] = EQ-    liftCompare _ [] (_:_) = LT-    liftCompare _ (_:_) [] = GT-    liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys---- | @since 4.9.0.0-instance Read1 [] where-    liftReadPrec _ rl = rl-    liftReadListPrec  = liftReadListPrecDefault-    liftReadList      = liftReadListDefault---- | @since 4.9.0.0-instance Show1 [] where-    liftShowsPrec _ sl _ = sl---- | @since 4.10.0.0-instance Eq1 NonEmpty where-  liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs---- | @since 4.10.0.0-instance Ord1 NonEmpty where-  liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs---- | @since 4.10.0.0-instance Read1 NonEmpty where-  liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do-    (a, s'') <- rdP 6 s'-    (":|", s''') <- lex s''-    (as, s'''') <- rdL s'''-    return (a :| as, s'''')) s---- | @since 4.10.0.0-instance Show1 NonEmpty where-  liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $-    shwP 6 a . showString " :| " . shwL as----- | @since 4.9.0.0-instance Eq2 (,) where-    liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2---- | @since 4.9.0.0-instance Ord2 (,) where-    liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =-        comp1 x1 x2 `mappend` comp2 y1 y2---- | @since 4.9.0.0-instance Read2 (,) where-    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do-        x <- rp1-        expectP (Punc ",")-        y <- rp2-        return (x,y)--    liftReadListPrec2 = liftReadListPrec2Default-    liftReadList2     = liftReadList2Default---- | @since 4.9.0.0-instance Show2 (,) where-    liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =-        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'---- | @since 4.15-instance Eq1 Solo where-  liftEq eq (Solo a) (Solo b) = a `eq` b---- | @since 4.9.0.0-instance (Eq a) => Eq1 ((,) a) where-    liftEq = liftEq2 (==)---- | @since 4.15-instance Ord1 Solo where-  liftCompare cmp (Solo a) (Solo b) = cmp a b---- | @since 4.9.0.0-instance (Ord a) => Ord1 ((,) a) where-    liftCompare = liftCompare2 compare---- | @since 4.15-instance Read1 Solo where-    liftReadPrec rp _ = readData (readUnaryWith rp "Solo" Solo)--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-instance (Read a) => Read1 ((,) a) where-    liftReadPrec = liftReadPrec2 readPrec readListPrec--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.15-instance Show1 Solo where-    liftShowsPrec sp _ d (Solo x) = showsUnaryWith sp "Solo" d x---- | @since 4.9.0.0-instance (Show a) => Show1 ((,) a) where-    liftShowsPrec = liftShowsPrec2 showsPrec showList----- | @since 4.16.0.0------ >>> eq2 ('x', True, "str") ('x', True, "str")--- True----instance Eq a => Eq2 ((,,) a) where-    liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) =-        u1 == v1 &&-        e1 x1 x2 && e2 y1 y2---- | @since 4.16.0.0------ >>> compare2 ('x', True, "aaa") ('x', True, "zzz")--- LT-instance Ord a => Ord2 ((,,) a) where-    liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) =-        compare u1 v1 `mappend`-        comp1 x1 x2 `mappend` comp2 y1 y2---- | @since 4.16.0.0------ >>> readPrec_to_S readPrec2 0 "('x', True, 2)" :: [((Char, Bool, Int), String)]--- [(('x',True,2),"")]----instance Read a => Read2 ((,,) a) where-    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do-        x1 <- readPrec-        expectP (Punc ",")-        y1 <- rp1-        expectP (Punc ",")-        y2 <- rp2-        return (x1,y1,y2)--    liftReadListPrec2 = liftReadListPrec2Default-    liftReadList2     = liftReadList2Default---- | @since 4.16.0.0------ >>> showsPrec2 0 ('x', True, 2 :: Int) ""--- "('x',True,2)"----instance Show a => Show2 ((,,) a) where-    liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2)-        = showChar '(' . showsPrec 0 x1-        . showChar ',' . sp1 0 y1-        . showChar ',' . sp2 0 y2-        . showChar ')'---- | @since 4.16.0.0-instance (Eq a, Eq b) => Eq1 ((,,) a b) where-    liftEq = liftEq2 (==)---- | @since 4.16.0.0-instance (Ord a, Ord b) => Ord1 ((,,) a b) where-    liftCompare = liftCompare2 compare---- | @since 4.16.0.0-instance (Read a, Read b) => Read1 ((,,) a b) where-    liftReadPrec = liftReadPrec2 readPrec readListPrec--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.16.0.0-instance (Show a, Show b) => Show1 ((,,) a b) where-    liftShowsPrec = liftShowsPrec2 showsPrec showList----- | @since 4.16.0.0------ >>> eq2 ('x', True, "str", 2) ('x', True, "str", 2 :: Int)--- True----instance (Eq a, Eq b) => Eq2 ((,,,) a b) where-    liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) =-        u1 == v1 &&-        u2 == v2 &&-        e1 x1 x2 && e2 y1 y2---- | @since 4.16.0.0------ >>> compare2 ('x', True, "str", 2) ('x', True, "str", 3 :: Int)--- LT----instance (Ord a, Ord b) => Ord2 ((,,,) a b) where-    liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) =-        compare u1 v1 `mappend`-        compare u2 v2 `mappend`-        comp1 x1 x2 `mappend` comp2 y1 y2---- | @since 4.16.0.0------ >>> readPrec_to_S readPrec2 0 "('x', True, 2, 4.5)" :: [((Char, Bool, Int, Double), String)]--- [(('x',True,2,4.5),"")]----instance (Read a, Read b) => Read2 ((,,,) a b) where-    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do-        x1 <- readPrec-        expectP (Punc ",")-        x2 <- readPrec-        expectP (Punc ",")-        y1 <- rp1-        expectP (Punc ",")-        y2 <- rp2-        return (x1,x2,y1,y2)--    liftReadListPrec2 = liftReadListPrec2Default-    liftReadList2     = liftReadList2Default---- | @since 4.16.0.0------ >>> showsPrec2 0 ('x', True, 2 :: Int, 4.5 :: Double) ""--- "('x',True,2,4.5)"----instance (Show a, Show b) => Show2 ((,,,) a b) where-    liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2)-        = showChar '(' . showsPrec 0 x1-        . showChar ',' . showsPrec 0 x2-        . showChar ',' . sp1 0 y1-        . showChar ',' . sp2 0 y2-        . showChar ')'---- | @since 4.16.0.0-instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where-    liftEq = liftEq2 (==)---- | @since 4.16.0.0-instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where-    liftCompare = liftCompare2 compare---- | @since 4.16.0.0-instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where-    liftReadPrec = liftReadPrec2 readPrec readListPrec--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.16.0.0-instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where-    liftShowsPrec = liftShowsPrec2 showsPrec showList----- | @since 4.9.0.0-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---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance Read2 Either where-    liftReadPrec2 rp1 _ rp2 _ = readData $-         readUnaryWith rp1 "Left" Left <|>-         readUnaryWith rp2 "Right" Right--    liftReadListPrec2 = liftReadListPrec2Default-    liftReadList2     = liftReadList2Default---- | @since 4.9.0.0-instance Show2 Either where-    liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x-    liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x---- | @since 4.9.0.0-instance (Eq a) => Eq1 (Either a) where-    liftEq = liftEq2 (==)---- | @since 4.9.0.0-instance (Ord a) => Ord1 (Either a) where-    liftCompare = liftCompare2 compare---- | @since 4.9.0.0-instance (Read a) => Read1 (Either a) where-    liftReadPrec = liftReadPrec2 readPrec readListPrec--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-instance (Show a) => Show1 (Either a) where-    liftShowsPrec = liftShowsPrec2 showsPrec showList---- Instances for other functors defined in the base package---- | @since 4.9.0.0-instance Eq1 Identity where-    liftEq eq (Identity x) (Identity y) = eq x y---- | @since 4.9.0.0-instance Ord1 Identity where-    liftCompare comp (Identity x) (Identity y) = comp x y---- | @since 4.9.0.0-instance Read1 Identity where-    liftReadPrec rp _ = readData $-         readUnaryWith rp "Identity" Identity--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-instance Show1 Identity where-    liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x---- | @since 4.9.0.0-instance Eq2 Const where-    liftEq2 eq _ (Const x) (Const y) = eq x y---- | @since 4.9.0.0-instance Ord2 Const where-    liftCompare2 comp _ (Const x) (Const y) = comp x y---- | @since 4.9.0.0-instance Read2 Const where-    liftReadPrec2 rp _ _ _ = readData $-         readUnaryWith rp "Const" Const--    liftReadListPrec2 = liftReadListPrec2Default-    liftReadList2     = liftReadList2Default---- | @since 4.9.0.0-instance Show2 Const where-    liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x---- | @since 4.9.0.0-instance (Eq a) => Eq1 (Const a) where-    liftEq = liftEq2 (==)--- | @since 4.9.0.0-instance (Ord a) => Ord1 (Const a) where-    liftCompare = liftCompare2 compare--- | @since 4.9.0.0-instance (Read a) => Read1 (Const a) where-    liftReadPrec = liftReadPrec2 readPrec readListPrec--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault--- | @since 4.9.0.0-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-  liftReadPrec _ _ = parens (expectP (Ident "Proxy") *> pure Proxy)--  liftReadListPrec = liftReadListPrecDefault-  liftReadList     = liftReadListDefault---- | @since 4.12.0.0-instance Eq1 Down where-    liftEq eq (Down x) (Down y) = eq x y---- | @since 4.12.0.0-instance Ord1 Down where-    liftCompare comp (Down x) (Down y) = comp x y---- | @since 4.12.0.0-instance Read1 Down where-    liftReadsPrec rp _ = readsData $-         readsUnaryWith rp "Down" Down---- | @since 4.12.0.0-instance Show1 Down where-    liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x---- | @since 4.16.0.0------ >>> eq1 (1 :+ 2) (1 :+ 2)--- True------ >>> eq1 (1 :+ 2) (1 :+ 3)--- False----instance Eq1 Complex where-    liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v---- | @since 4.16.0.0------ >>> readPrec_to_S readPrec1 0 "(2 % 3) :+ (3 % 4)" :: [(Complex Rational, String)]--- [(2 % 3 :+ 3 % 4,"")]----instance Read1 Complex where-    liftReadPrec rp _  = parens $ prec complexPrec $ do-        x <- step rp-        expectP (Symbol ":+")-        y <- step rp-        return (x :+ y)-      where-        complexPrec = 6--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.16.0.0------ >>> showsPrec1 0 (2 :+ 3) ""--- "2 :+ 3"----instance Show1 Complex where-    liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $-        sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y-      where-        complexPrec = 6---- 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.------ @since 4.9.0.0-readsData :: (String -> ReadS a) -> Int -> ReadS a-readsData reader d =-    readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]---- | @'readData' p@ 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 'readUnaryWith' and 'readBinaryWith', and combined with--- '(<|>)' from the 'Alternative' class.------ @since 4.10.0.0-readData :: ReadPrec a -> ReadPrec a-readData reader = parens $ prec 10 reader---- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor--- and then parses its argument using @rp@.------ @since 4.9.0.0-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]---- | @'readUnaryWith' rp n c'@ matches the name of a unary data constructor--- and then parses its argument using @rp@.------ @since 4.10.0.0-readUnaryWith :: ReadPrec a -> String -> (a -> t) -> ReadPrec t-readUnaryWith rp name cons = do-    expectP $ Ident name-    x <- step rp-    return $ cons x---- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary--- data constructor and then parses its arguments using @rp1@ and @rp2@--- respectively.------ @since 4.9.0.0-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]---- | @'readBinaryWith' rp1 rp2 n c'@ matches the name of a binary--- data constructor and then parses its arguments using @rp1@ and @rp2@--- respectively.------ @since 4.10.0.0-readBinaryWith :: ReadPrec a -> ReadPrec b ->-    String -> (a -> b -> t) -> ReadPrec t-readBinaryWith rp1 rp2 name cons = do-    expectP $ Ident name-    x <- step rp1-    y <- step rp2-    return $ cons x y---- | @'showsUnaryWith' sp n d x@ produces the string representation of a--- unary data constructor with name @n@ and argument @x@, in precedence--- context @d@.------ @since 4.9.0.0-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@.------ @since 4.9.0.0-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'.------ @since 4.9.0.0-{-# 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'.------ @since 4.9.0.0-{-# 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'.------ @since 4.9.0.0-{-# 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@.------ @since 4.9.0.0-{-# 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@.------ @since 4.9.0.0-{-# 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@.------ @since 4.9.0.0-{-# 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->     liftReadPrec rp rl = readData $->         readUnaryWith rp "Zero" Zero <|>->         readUnaryWith (liftReadPrec rp rl) "One" One <|>->         readBinaryWith rp (liftReadPrec rp rl) "Two" Two->     liftReadListPrec = liftReadListPrecDefault--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---}
− Data/Functor/Compose.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- 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.Coerce (coerce)-import Data.Data (Data)-import Data.Type.Equality (TestEquality(..), (:~:)(..))-import GHC.Generics (Generic, Generic1)-import Text.Read (Read(..), readListDefault, readListPrecDefault)--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     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           , Semigroup -- ^ @since 4.16.0.0-           , Monoid    -- ^ @since 4.16.0.0-           )---- Instances of lifted Prelude classes---- | @since 4.9.0.0-instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where-    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y---- | @since 4.9.0.0-instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where-    liftCompare comp (Compose x) (Compose y) =-        liftCompare (liftCompare comp) x y---- | @since 4.9.0.0-instance (Read1 f, Read1 g) => Read1 (Compose f g) where-    liftReadPrec rp rl = readData $-        readUnaryWith (liftReadPrec rp' rl') "Compose" Compose-      where-        rp' = liftReadPrec     rp rl-        rl' = liftReadListPrec rp rl--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where-    (==) = eq1---- | @since 4.9.0.0-instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where-    compare = compare1---- | @since 4.9.0.0-instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where-    readPrec = readPrec1--    readListPrec = readListPrecDefault-    readList     = readListDefault---- | @since 4.9.0.0-instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where-    showsPrec = showsPrec1---- Functor instances---- | @since 4.9.0.0-instance (Functor f, Functor g) => Functor (Compose f g) where-    fmap f (Compose x) = Compose (fmap (fmap f) x)-    a <$ (Compose x) = Compose (fmap (a <$) x)---- | @since 4.9.0.0-instance (Foldable f, Foldable g) => Foldable (Compose f g) where-    foldMap f (Compose t) = foldMap (foldMap f) t---- | @since 4.9.0.0-instance (Traversable f, Traversable g) => Traversable (Compose f g) where-    traverse f (Compose t) = Compose <$> traverse (traverse f) t---- | @since 4.9.0.0-instance (Applicative f, Applicative g) => Applicative (Compose f g) where-    pure x = Compose (pure (pure x))-    Compose f <*> Compose x = Compose (liftA2 (<*>) f x)-    liftA2 f (Compose x) (Compose y) =-      Compose (liftA2 (liftA2 f) x y)---- | @since 4.9.0.0-instance (Alternative f, Applicative g) => Alternative (Compose f g) where-    empty = Compose empty-    (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a))-      :: forall a . Compose f g a -> Compose f g a -> Compose f g a---- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.------ @since 4.14.0.0-instance (TestEquality f) => TestEquality (Compose f g) where-  testEquality (Compose x) (Compose y) =-    case testEquality x y of -- :: Maybe (g x :~: g y)-      Just Refl -> Just Refl -- :: Maybe (x :~: y)-      Nothing   -> Nothing
− Data/Functor/Const.hs 
@@ -1,94 +0,0 @@-{-# 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.Ix (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       -- ^ @since 4.9.0.0-             , Bounded    -- ^ @since 4.9.0.0-             , Enum       -- ^ @since 4.9.0.0-             , Eq         -- ^ @since 4.9.0.0-             , FiniteBits -- ^ @since 4.9.0.0-             , Floating   -- ^ @since 4.9.0.0-             , Fractional -- ^ @since 4.9.0.0-             , Generic    -- ^ @since 4.9.0.0-             , Generic1   -- ^ @since 4.9.0.0-             , Integral   -- ^ @since 4.9.0.0-             , Ix         -- ^ @since 4.9.0.0-             , Semigroup  -- ^ @since 4.9.0.0-             , Monoid     -- ^ @since 4.9.0.0-             , Num        -- ^ @since 4.9.0.0-             , Ord        -- ^ @since 4.9.0.0-             , Real       -- ^ @since 4.9.0.0-             , RealFrac   -- ^ @since 4.9.0.0-             , RealFloat  -- ^ @since 4.9.0.0-             , Storable   -- ^ @since 4.9.0.0-             )---- | This instance would be equivalent to the derived instances of the--- 'Const' newtype if the 'getConst' field were removed------ @since 4.8.0.0-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 'getConst' field were removed------ @since 4.8.0.0-instance Show a => Show (Const a b) where-    showsPrec d (Const x) = showParen (d > 10) $-                            showString "Const " . showsPrec 11 x---- | @since 4.7.0.0-instance Foldable (Const m) where-    foldMap _ _ = mempty---- | @since 2.01-instance Functor (Const m) where-    fmap _ (Const v) = Const v---- | @since 2.0.1-instance Monoid m => Applicative (Const m) where-    pure _ = Const mempty-    liftA2 _ (Const x) (Const y) = Const (x `mappend` y)-    (<*>) = 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.
− Data/Functor/Contravariant.hs 
@@ -1,378 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Contravariant--- Copyright   :  (C) 2007-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,--- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'--- the definition of 'Contravariant' for a given ADT is unambiguous.------ @since 4.12.0.0-------------------------------------------------------------------------------module Data.Functor.Contravariant (-  -- * Contravariant Functors-    Contravariant(..)-  , phantom--  -- * Operators-  , (>$<), (>$$<), ($<)--  -- * Predicates-  , Predicate(..)--  -- * Comparisons-  , Comparison(..)-  , defaultComparison--  -- * Equivalence Relations-  , Equivalence(..)-  , defaultEquivalence-  , comparisonEquivalence--  -- * Dual arrows-  , Op(..)-  ) where--import Control.Applicative-import Control.Category-import Data.Function (on)--import Data.Functor.Product-import Data.Functor.Sum-import Data.Functor.Compose--import Data.Monoid (Alt(..), All(..))-import Data.Proxy-import GHC.Generics--import Prelude hiding ((.), id)---- | The class of contravariant functors.------ Whereas in Haskell, one can think of a 'Functor' as containing or producing--- values, a contravariant functor is a functor that can be thought of as--- /consuming/ values.------ As an example, consider the type of predicate functions  @a -> Bool@. One--- such predicate might be @negative x = x < 0@, which--- classifies integers as to whether they are negative. However, given this--- predicate, we can re-use it in other situations, providing we have a way to--- map values /to/ integers. For instance, we can use the @negative@ predicate--- on a person's bank balance to work out if they are currently overdrawn:------ @--- newtype Predicate a = Predicate { getPredicate :: a -> Bool }------ instance Contravariant Predicate where---   contramap :: (a' -> a) -> (Predicate a -> Predicate a')---   contramap f (Predicate p) = Predicate (p . f)---                                          |   `- First, map the input...---                                          `----- then apply the predicate.------ overdrawn :: Predicate Person--- overdrawn = contramap personBankBalance negative--- @------ Any instance should be subject to the following laws:------ [Identity]    @'contramap' 'id'      = 'id'@--- [Composition] @'contramap' (g . f) = 'contramap' f . 'contramap' g@------ Note, that the second law follows from the free theorem of the type of--- 'contramap' and the first law, so you need only check that the former--- condition holds.--class Contravariant f where-  contramap :: (a' -> a) -> (f a -> f a')--  -- | Replace all locations in the output with the same value.-  -- The default definition is @'contramap' . 'const'@, but this may be-  -- overridden with a more efficient version.-  (>$) :: b -> f b -> f a-  (>$) = contramap . const---- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor--- in the laws of each of those classes, it can't actually use its argument in--- any meaningful capacity.------ This method is surprisingly useful. Where both instances exist and are--- lawful we have the following laws:------ @--- 'fmap'      f ≡ 'phantom'--- 'contramap' f ≡ 'phantom'--- @-phantom :: (Functor f, Contravariant f) => f a -> f b-phantom x = () <$ x $< ()--infixl 4 >$, $<, >$<, >$$<---- | This is '>$' with its arguments flipped.-($<) :: Contravariant f => f b -> b -> f a-($<) = flip (>$)---- | This is an infix alias for 'contramap'.-(>$<) :: Contravariant f => (a -> b) -> (f b -> f a)-(>$<) = contramap---- | This is an infix version of 'contramap' with the arguments flipped.-(>$$<) :: Contravariant f => f b -> (a -> b) -> f a-(>$$<) = flip contramap--deriving newtype instance Contravariant f => Contravariant (Alt f)-deriving newtype instance Contravariant f => Contravariant (Rec1 f)-deriving newtype instance Contravariant f => Contravariant (M1 i c f)--instance Contravariant V1 where-  contramap :: (a' -> a) -> (V1 a -> V1 a')-  contramap _ x = case x of--instance Contravariant U1 where-  contramap :: (a' -> a) -> (U1 a -> U1 a')-  contramap _ _ = U1--instance Contravariant (K1 i c) where-  contramap :: (a' -> a) -> (K1 i c a -> K1 i c a')-  contramap _ (K1 c) = K1 c--instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where-  contramap :: (a' -> a) -> ((f :*: g) a -> (f :*: g) a')-  contramap f (xs :*: ys) = contramap f xs :*: contramap f ys--instance (Functor f, Contravariant g) => Contravariant (f :.: g) where-  contramap :: (a' -> a) -> ((f :.: g) a -> (f :.: g) a')-  contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)--instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where-  contramap :: (a' -> a) -> ((f :+: g) a -> (f :+: g) a')-  contramap f (L1 xs) = L1 (contramap f xs)-  contramap f (R1 ys) = R1 (contramap f ys)--instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where-  contramap :: (a' -> a) -> (Sum f g a -> Sum f g a')-  contramap f (InL xs) = InL (contramap f xs)-  contramap f (InR ys) = InR (contramap f ys)--instance (Contravariant f, Contravariant g)-      => Contravariant (Product f g) where-  contramap :: (a' -> a) -> (Product f g a -> Product f g a')-  contramap f (Pair a b) = Pair (contramap f a) (contramap f b)--instance Contravariant (Const a) where-  contramap :: (b' -> b) -> (Const a b -> Const a b')-  contramap _ (Const a) = Const a--instance (Functor f, Contravariant g) => Contravariant (Compose f g) where-  contramap :: (a' -> a) -> (Compose f g a -> Compose f g a')-  contramap f (Compose fga) = Compose (fmap (contramap f) fga)--instance Contravariant Proxy where-  contramap :: (a' -> a) -> (Proxy a -> Proxy a')-  contramap _ _ = Proxy--newtype Predicate a = Predicate { getPredicate :: a -> Bool }-  deriving-    ( -- | @('<>')@ on predicates uses logical conjunction @('&&')@ on-      -- the results. Without newtypes this equals @'liftA2' (&&)@.-      ---      -- @-      -- (<>) :: Predicate a -> Predicate a -> Predicate a-      -- Predicate pred <> Predicate pred' = Predicate \a ->-      --   pred a && pred' a-      -- @-      Semigroup-    , -- | @'mempty'@ on predicates always returns @True@. Without-      -- newtypes this equals @'pure' True@.-      ---      -- @-      -- mempty :: Predicate a-      -- mempty = \_ -> True-      -- @-      Monoid-    )-  via a -> All--  deriving-    ( -- | A 'Predicate' is a 'Contravariant' 'Functor', because-      -- 'contramap' can apply its function argument to the input of-      -- the predicate.-      ---      -- Without newtypes @'contramap' f@ equals precomposing with @f@-      -- (= @(. f)@).-      ---      -- @-      -- contramap :: (a' -> a) -> (Predicate a -> Predicate a')-      -- contramap f (Predicate g) = Predicate (g . f)-      -- @-      Contravariant-    )-  via Op Bool---- | Defines a total ordering on a type as per 'compare'.------ This condition is not checked by the types. You must ensure that the--- supplied values are valid total orderings yourself.-newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }-  deriving-  newtype-    ( -- | @('<>')@ on comparisons combines results with @('<>')-      -- \@Ordering@. Without newtypes this equals @'liftA2' ('liftA2'-      -- ('<>'))@.-      ---      -- @-      -- (<>) :: Comparison a -> Comparison a -> Comparison a-      -- Comparison cmp <> Comparison cmp' = Comparison \a a' ->-      --   cmp a a' <> cmp a a'-      -- @-      Semigroup-    , -- | @'mempty'@ on comparisons always returns @EQ@. Without-      -- newtypes this equals @'pure' ('pure' EQ)@.-      ---      -- @-      -- mempty :: Comparison a-      -- mempty = Comparison \_ _ -> EQ-      -- @-      Monoid-    )---- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to each input of the comparison function.-instance Contravariant Comparison where-  contramap :: (a' -> a) -> (Comparison a -> Comparison a')-  contramap f (Comparison g) = Comparison (on g f)---- | Compare using 'compare'.-defaultComparison :: Ord a => Comparison a-defaultComparison = Comparison compare---- | This data type represents an equivalence relation.------ Equivalence relations are expected to satisfy three laws:------ [Reflexivity]:  @'getEquivalence' f a a = True@--- [Symmetry]:     @'getEquivalence' f a b = 'getEquivalence' f b a@--- [Transitivity]:---    If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True'---    then so is @'getEquivalence' f a c@.------ The types alone do not enforce these laws, so you'll have to check them--- yourself.-newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }-  deriving-    ( -- | @('<>')@ on equivalences uses logical conjunction @('&&')@-      -- on the results. Without newtypes this equals @'liftA2'-      -- ('liftA2' (&&))@.-      ---      -- @-      -- (<>) :: Equivalence a -> Equivalence a -> Equivalence a-      -- Equivalence equiv <> Equivalence equiv' = Equivalence \a b ->-      --   equiv a b && equiv a b-      -- @-      Semigroup-    , -- | @'mempty'@ on equivalences always returns @True@. Without-      -- newtypes this equals @'pure' ('pure' True)@.-      ---      -- @-      -- mempty :: Equivalence a-      -- mempty = Equivalence \_ _ -> True-      -- @-      Monoid-    )-  via a -> a -> All---- | Equivalence relations are 'Contravariant', because you can--- apply the contramapped function to each input to the equivalence--- relation.-instance Contravariant Equivalence where-  contramap :: (a' -> a) -> (Equivalence a -> Equivalence a')-  contramap f (Equivalence g) = Equivalence (on g f)---- | Check for equivalence with '=='.------ Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.-defaultEquivalence :: Eq a => Equivalence a-defaultEquivalence = Equivalence (==)--comparisonEquivalence :: Comparison a -> Equivalence a-comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ---- | Dual function arrows.-newtype Op a b = Op { getOp :: b -> a }-  deriving-  newtype-    ( -- | @('<>') \@(Op a b)@ without newtypes is @('<>') \@(b->a)@ =-      -- @liftA2 ('<>')@. This lifts the 'Semigroup' operation-      -- @('<>')@ over the output of @a@.-      ---      -- @-      -- (<>) :: Op a b -> Op a b -> Op a b-      -- Op f <> Op g = Op \a -> f a <> g a-      -- @-      Semigroup-    , -- | @'mempty' \@(Op a b)@ without newtypes is @mempty \@(b->a)@-      -- = @\_ -> mempty@.-      ---      -- @-      -- mempty :: Op a b-      -- mempty = Op \_ -> mempty-      -- @-      Monoid-    )--instance Category Op where-  id :: Op a a-  id = Op id--  (.) :: Op b c -> Op a b -> Op a c-  Op f . Op g = Op (g . f)--instance Contravariant (Op a) where-  contramap :: (b' -> b) -> (Op a b -> Op a b')-  contramap f g = Op (getOp g . f)--instance Num a => Num (Op a b) where-  Op f + Op g = Op $ \a -> f a + g a-  Op f * Op g = Op $ \a -> f a * g a-  Op f - Op g = Op $ \a -> f a - g a-  abs (Op f) = Op $ abs . f-  signum (Op f) = Op $ signum . f-  fromInteger = Op . const . fromInteger--instance Fractional a => Fractional (Op a b) where-  Op f / Op g = Op $ \a -> f a / g a-  recip (Op f) = Op $ recip . f-  fromRational = Op . const . fromRational--instance Floating a => Floating (Op a b) where-  pi = Op $ const pi-  exp (Op f) = Op $ exp . f-  sqrt (Op f) = Op $ sqrt . f-  log (Op f) = Op $ log . f-  sin (Op f) = Op $ sin . f-  tan (Op f) = Op $ tan . f-  cos (Op f) = Op $ cos . f-  asin (Op f) = Op $ asin . f-  atan (Op f) = Op $ atan . f-  acos (Op f) = Op $ acos . f-  sinh (Op f) = Op $ sinh . f-  tanh (Op f) = Op $ tanh . f-  cosh (Op f) = Op $ cosh . f-  asinh (Op f) = Op $ asinh . f-  atanh (Op f) = Op $ atanh . f-  acosh (Op f) = Op $ acosh . f-  Op f ** Op g = Op $ \a -> f a ** g a-  logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)
− Data/Functor/Identity.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Identity--- Copyright   :  (c) Andy Gill 2001,---                (c) Oregon Graduate Institute of Science and Technology 2001--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  ross@soi.city.ac.uk--- Stability   :  experimental--- Portability :  portable------ The identity functor and monad.------ This trivial type constructor serves two purposes:------ * It can be used with functions parameterized by functor or monad classes.------ * It can be used as a base monad to which a series of monad---   transformers may be applied to construct a composite monad.---   Most monad transformer modules include the special case of---   applying the transformer to 'Identity'.  For example, @State s@---   is an abbreviation for @StateT s 'Identity'@.------ @since 4.8.0.0--------------------------------------------------------------------------------module Data.Functor.Identity (-    Identity(..),-  ) where--import Control.Monad.Fix-import Data.Bits (Bits, FiniteBits)-import Data.Coerce-import Data.Foldable-import Data.Functor.Utils ((#.))-import Foreign.Storable (Storable)-import GHC.Ix (Ix)-import GHC.Base ( Applicative(..), Eq(..), Functor(..), Monad(..)-                , Semigroup, Monoid, Ord(..), ($), (.) )-import GHC.Enum (Bounded, Enum)-import GHC.Float (Floating, RealFloat)-import GHC.Generics (Generic, Generic1)-import GHC.Num (Num)-import GHC.Read (Read(..), lex, readParen)-import GHC.Real (Fractional, Integral, Real, RealFrac)-import GHC.Show (Show(..), showParen, showString)-import GHC.Types (Bool(..))---- | Identity functor and monad. (a non-strict monad)------ @since 4.8.0.0-newtype Identity a = Identity { runIdentity :: a }-    deriving ( Bits       -- ^ @since 4.9.0.0-             , Bounded    -- ^ @since 4.9.0.0-             , Enum       -- ^ @since 4.9.0.0-             , Eq         -- ^ @since 4.8.0.0-             , FiniteBits -- ^ @since 4.9.0.0-             , Floating   -- ^ @since 4.9.0.0-             , Fractional -- ^ @since 4.9.0.0-             , Generic    -- ^ @since 4.8.0.0-             , Generic1   -- ^ @since 4.8.0.0-             , Integral   -- ^ @since 4.9.0.0-             , Ix         -- ^ @since 4.9.0.0-             , Semigroup  -- ^ @since 4.9.0.0-             , Monoid     -- ^ @since 4.9.0.0-             , Num        -- ^ @since 4.9.0.0-             , Ord        -- ^ @since 4.8.0.0-             , Real       -- ^ @since 4.9.0.0-             , RealFrac   -- ^ @since 4.9.0.0-             , RealFloat  -- ^ @since 4.9.0.0-             , Storable   -- ^ @since 4.9.0.0-             )---- | This instance would be equivalent to the derived instances of the--- 'Identity' newtype if the 'runIdentity' field were removed------ @since 4.8.0.0-instance (Read a) => Read (Identity a) where-    readsPrec d = readParen (d > 10) $ \ r ->-        [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s]---- | This instance would be equivalent to the derived instances of the--- 'Identity' newtype if the 'runIdentity' field were removed------ @since 4.8.0.0-instance (Show a) => Show (Identity a) where-    showsPrec d (Identity x) = showParen (d > 10) $-        showString "Identity " . showsPrec 11 x---- ------------------------------------------------------------------------------ Identity instances for Functor and Monad---- | @since 4.8.0.0-instance Foldable Identity where-    foldMap                = coerce--    elem                   = (. runIdentity) #. (==)-    foldl                  = coerce-    foldl'                 = coerce-    foldl1 _               = runIdentity-    foldr f z (Identity x) = f x z-    foldr'                 = foldr-    foldr1 _               = runIdentity-    length _               = 1-    maximum                = runIdentity-    minimum                = runIdentity-    null _                 = False-    product                = runIdentity-    sum                    = runIdentity-    toList (Identity x)    = [x]---- | @since 4.8.0.0-instance Functor Identity where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Identity where-    pure     = Identity-    (<*>)    = coerce-    liftA2   = coerce---- | @since 4.8.0.0-instance Monad Identity where-    m >>= k  = k (runIdentity m)---- | @since 4.8.0.0-instance MonadFix Identity where-    mfix f   = Identity (fix (runIdentity . f))
− Data/Functor/Product.hs 
@@ -1,134 +0,0 @@-{-# 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.Functor.Classes-import GHC.Generics (Generic, Generic1)-import Text.Read (Read(..), readListDefault, readListPrecDefault)---- | Lifted product of functors.-data Product f g a = Pair (f a) (g a)-  deriving ( Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where-    liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance (Read1 f, Read1 g) => Read1 (Product f g) where-    liftReadPrec rp rl = readData $-        readBinaryWith (liftReadPrec rp rl) (liftReadPrec rp rl) "Pair" Pair--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)-    where (==) = eq1---- | @since 4.9.0.0-instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where-    compare = compare1---- | @since 4.9.0.0-instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where-    readPrec = readPrec1--    readListPrec = readListPrecDefault-    readList     = readListDefault---- | @since 4.9.0.0-instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where-    showsPrec = showsPrec1---- | @since 4.9.0.0-instance (Functor f, Functor g) => Functor (Product f g) where-    fmap f (Pair x y) = Pair (fmap f x) (fmap f y)-    a <$ (Pair x y) = Pair (a <$ x) (a <$ y)---- | @since 4.9.0.0-instance (Foldable f, Foldable g) => Foldable (Product f g) where-    foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y---- | @since 4.9.0.0-instance (Traversable f, Traversable g) => Traversable (Product f g) where-    traverse f (Pair x y) = liftA2 Pair (traverse f x) (traverse f y)---- | @since 4.9.0.0-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)-    liftA2 f (Pair a b) (Pair x y) = Pair (liftA2 f a x) (liftA2 f b y)---- | @since 4.9.0.0-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)---- | @since 4.9.0.0-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---- | @since 4.9.0.0-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)---- | @since 4.9.0.0-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---- | @since 4.9.0.0-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)---- | @since 4.16.0.0-instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Product f g a) where-    Pair x1 y1 <> Pair x2 y2 = Pair (x1 <> x2) (y1 <> y2)---- | @since 4.16.0.0-instance (Monoid (f a), Monoid (g a)) => Monoid (Product f g a) where-    mempty = Pair mempty mempty
− Data/Functor/Sum.hs 
@@ -1,99 +0,0 @@-{-# 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 Control.Applicative ((<|>))-import Data.Data (Data)-import Data.Functor.Classes-import GHC.Generics (Generic, Generic1)-import Text.Read (Read(..), readListDefault, readListPrecDefault)---- | Lifted sum of functors.-data Sum f g a = InL (f a) | InR (g a)-  deriving ( Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where-    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---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance (Read1 f, Read1 g) => Read1 (Sum f g) where-    liftReadPrec rp rl = readData $-        readUnaryWith (liftReadPrec rp rl) "InL" InL <|>-        readUnaryWith (liftReadPrec rp rl) "InR" InR--    liftReadListPrec = liftReadListPrecDefault-    liftReadList     = liftReadListDefault---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where-    (==) = eq1--- | @since 4.9.0.0-instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where-    compare = compare1--- | @since 4.9.0.0-instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where-    readPrec = readPrec1--    readListPrec = readListPrecDefault-    readList     = readListDefault--- | @since 4.9.0.0-instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where-    showsPrec = showsPrec1---- | @since 4.9.0.0-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)--    a <$ (InL x) = InL (a <$ x)-    a <$ (InR y) = InR (a <$ y)---- | @since 4.9.0.0-instance (Foldable f, Foldable g) => Foldable (Sum f g) where-    foldMap f (InL x) = foldMap f x-    foldMap f (InR y) = foldMap f y---- | @since 4.9.0.0-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
− Data/Functor/Utils.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- This is a non-exposed internal module.------ This code contains utility function and data structures that are used--- to improve the efficiency of several instances in the Data.* namespace.-------------------------------------------------------------------------------module Data.Functor.Utils where--import Data.Coerce (Coercible, coerce)-import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..)-                , Semigroup(..), ($), otherwise )---- We don't expose 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--- instance. We may eventually want to add both versions, but we don't want to--- trample on anyone's toes by imposing Max = MaxMaybe.--newtype Max a = Max {getMax :: Maybe a}-newtype Min a = Min {getMin :: Maybe a}---- | @since 4.11.0.0-instance Ord a => Semigroup (Max a) where-    {-# INLINE (<>) #-}-    m <> Max Nothing = m-    Max Nothing <> n = n-    (Max m@(Just x)) <> (Max n@(Just y))-      | x >= y    = Max m-      | otherwise = Max n---- | @since 4.8.0.0-instance Ord a => Monoid (Max a) where-    mempty = Max Nothing---- | @since 4.11.0.0-instance Ord a => Semigroup (Min a) where-    {-# INLINE (<>) #-}-    m <> Min Nothing = m-    Min Nothing <> n = n-    (Min m@(Just x)) <> (Min n@(Just y))-      | x <= y    = Min m-      | otherwise = Min n---- | @since 4.8.0.0-instance Ord a => Monoid (Min a) where-    mempty = Min Nothing---- left-to-right state-transforming monad-newtype StateL s a = StateL { runStateL :: s -> (s, a) }---- | @since 4.0-instance Functor (StateL s) where-    fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v)---- | @since 4.0-instance Applicative (StateL s) where-    pure x = StateL (\ s -> (s, x))-    StateL kf <*> StateL kv = StateL $ \ s ->-        let (s', f) = kf s-            (s'', v) = kv s'-        in (s'', f v)-    liftA2 f (StateL kx) (StateL ky) = StateL $ \s ->-        let (s', x) = kx s-            (s'', y) = ky s'-        in (s'', f x y)---- right-to-left state-transforming monad-newtype StateR s a = StateR { runStateR :: s -> (s, a) }---- | @since 4.0-instance Functor (StateR s) where-    fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v)---- | @since 4.0-instance Applicative (StateR s) where-    pure x = StateR (\ s -> (s, x))-    StateR kf <*> StateR kv = StateR $ \ s ->-        let (s', v) = kv s-            (s'', f) = kf s'-        in (s'', f v)-    liftA2 f (StateR kx) (StateR ky) = StateR $ \ s ->-        let (s', y) = ky s-            (s'', x) = kx s'-        in (s'', f x y)---- See Note [Function coercion]-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = coerce-{-# INLINE (#.) #-}--{--Note [Function coercion]-~~~~~~~~~~~~~~~~~~~~~~~--Several functions here use (#.) instead of (.) to avoid potential efficiency-problems relating to #7542. The problem, in a nutshell:--If N is a newtype constructor, then N x will always have the same-representation as x (something similar applies for a newtype deconstructor).-However, if f is a function,--N . f = \x -> N (f x)--This looks almost the same as f, but the eta expansion lifts it--the lhs could-be _|_, but the rhs never is. This can lead to very inefficient code.  Thus we-steal a technique from Shachaf and Edward Kmett and adapt it to the current-(rather clean) setting. Instead of using  N . f,  we use  N #. f, which is-just--coerce f `asTypeOf` (N . f)--That is, we just *pretend* that f has the right type, and thanks to the safety-of coerce, the type checker guarantees that nothing really goes wrong. We still-have to be a bit careful, though: remember that #. completely ignores the-*value* of its left operand.--}
− Data/IORef.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UnboxedTuples #-}--------------------------------------------------------------------------------- |--- Module      :  Data.IORef--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Mutable references in the IO monad.-----------------------------------------------------------------------------------module Data.IORef-  (-        -- * IORefs-        IORef,                -- abstract, instance of: Eq, Typeable-        newIORef,-        readIORef,-        writeIORef,-        modifyIORef,-        modifyIORef',-        atomicModifyIORef,-        atomicModifyIORef',-        atomicWriteIORef,-        mkWeakIORef,-        -- ** Memory Model--        -- $memmodel--        ) where--import GHC.Base-import GHC.STRef-import GHC.IORef-import GHC.Weak---- |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#)) (IO finalizer) = IO $ \s ->-    case mkWeak# r# r finalizer s of (# s1, w #) -> (# s1, Weak w #)---- |Mutate the contents of an 'IORef'.------ Be warned that 'modifyIORef' does not apply the function strictly.  This--- means if the program calls 'modifyIORef' many times, but seldom uses the--- value, thunks will pile up in memory resulting in a space leak.  This is a--- common mistake made when using an IORef as a counter.  For example, the--- following will likely produce a stack overflow:------ >ref <- newIORef 0--- >replicateM_ 1000000 $ modifyIORef ref (+1)--- >readIORef ref >>= print------ To avoid this problem, use 'modifyIORef'' instead.-modifyIORef :: IORef a -> (a -> a) -> IO ()-modifyIORef ref f = readIORef ref >>= writeIORef ref . f---- |Strict version of 'modifyIORef'------ @since 4.6.0.0-modifyIORef' :: IORef a -> (a -> a) -> IO ()-modifyIORef' ref f = do-    x <- readIORef ref-    let x' = f x-    x' `seq` writeIORef ref x'---- |Atomically modifies the contents of an 'IORef'.------ This function is useful for using 'IORef' in a safe way in a multithreaded--- program.  If you only have one 'IORef', then using 'atomicModifyIORef' to--- access and modify it will prevent race conditions.------ Extending the atomicity to multiple 'IORef's is problematic, so it--- is recommended that if you need to do anything more complicated--- then using 'Control.Concurrent.MVar.MVar' instead is a good idea.------ 'atomicModifyIORef' does not apply the function strictly.  This is important--- to know even if all you are doing is replacing the value.  For example, this--- will leak memory:------ >ref <- newIORef '1'--- >forever $ atomicModifyIORef ref (\_ -> ('2', ()))------ Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem.----atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORef ref f = do-  (_old, ~(_new, res)) <- atomicModifyIORef2 ref f-  pure res---- | Variant of 'writeIORef' with the \"barrier to reordering\" property that--- 'atomicModifyIORef' has.------ @since 4.6.0.0-atomicWriteIORef :: IORef a -> a -> IO ()-atomicWriteIORef ref a = do-  _ <- atomicSwapIORef ref a-  pure ()--{- $memmodel--  In a concurrent program, 'IORef' operations may appear out-of-order-  to another thread, depending on the memory model of the underlying-  processor architecture.  For example, on x86, loads can move ahead-  of stores, so in the following example:--  > import Data.IORef-  > import Control.Monad (unless)-  > import Control.Concurrent (forkIO, threadDelay)-  >-  > maybePrint :: IORef Bool -> IORef Bool -> IO ()-  > maybePrint myRef yourRef = do-  >   writeIORef myRef True-  >   yourVal <- readIORef yourRef-  >   unless yourVal $ putStrLn "critical section"-  >-  > main :: IO ()-  > main = do-  >   r1 <- newIORef False-  >   r2 <- newIORef False-  >   forkIO $ maybePrint r1 r2-  >   forkIO $ maybePrint r2 r1-  >   threadDelay 1000000--  it is possible that the string @"critical section"@ is printed-  twice, even though there is no interleaving of the operations of the-  two threads that allows that outcome.  The memory model of x86-  allows 'readIORef' to happen before the earlier 'writeIORef'.--  The implementation is required to ensure that reordering of memory-  operations cannot cause type-correct code to go wrong.  In-  particular, when inspecting the value read from an 'IORef', the-  memory writes that created that value must have occurred from the-  point of view of the current thread.--  'atomicModifyIORef' acts as a barrier to reordering.  Multiple-  'atomicModifyIORef' operations occur in strict program order.  An-  'atomicModifyIORef' is never observed to take place ahead of any-  earlier (in program order) 'IORef' operations, or after any later-  'IORef' operations.---}-
− Data/Int.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Int--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Signed integer types-----------------------------------------------------------------------------------module Data.Int-  ( -        -- * Signed integer types-        Int,-        Int8, Int16, Int32, Int64,--        -- * Notes--        -- $notes-        ) where--import GHC.Base ( Int )-import GHC.Int  ( Int8, Int16, Int32, Int64 )--{- $notes--* All arithmetic is performed modulo 2^n, where @n@ is the number of-  bits in the type.--* For coercing between any two integer types, use 'Prelude.fromIntegral',-  which is specialized for all the common cases so should be fast-  enough.  Coercing word types (see "Data.Word") to and from integer-  types preserves representation, not sign.--* The rules that hold for 'Prelude.Enum' instances over a-  bounded type such as 'Int' (see the section of the-  Haskell report dealing with arithmetic sequences) also hold for the-  'Prelude.Enum' instances over the various-  'Int' types defined here.--* Right and left shifts by amounts greater than or equal to the width-  of the type result in either zero or -1, depending on the sign of-  the value being shifted.  This is contrary to the behaviour in C,-  which is undefined; a common interpretation is to truncate the shift-  count to the width of the type, for example @1 \<\< 32-  == 1@ in some C implementations.--}-
− Data/Ix.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Ix--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ The 'Ix' class is used to map a contiguous subrange of values in--- type onto integers.  It is used primarily for array indexing--- (see the array package).  'Ix' uses row-major order.--- --------------------------------------------------------------------------------module Data.Ix-    (-    -- * The 'Ix' class-        Ix-          ( range-          , index-          , inRange-          , rangeSize-          )-    -- Ix instances:-    ---    --  Ix Char-    --  Ix Int-    --  Ix Integer-    --  Ix Bool-    --  Ix Ordering-    --  Ix ()-    --  (Ix a, Ix b) => Ix (a, b)-    --  ...--    -- * Deriving Instances of 'Ix'-    -- | Derived instance declarations for the class 'Ix' are only possible-    -- for enumerations (i.e. datatypes having only nullary constructors)-    -- and single-constructor datatypes, including arbitrarily large tuples,-    -- whose constituent types are instances of 'Ix'. -    -- -    -- * For an enumeration, the nullary constructors are assumed to be-    -- numbered left-to-right with the indices being 0 to n-1 inclusive. This-    -- is the same numbering defined by the 'Enum' class. For example, given-    -- the datatype: -    -- -    -- >        data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet-    -- -    -- we would have: -    -- -    -- >        range   (Yellow,Blue)        ==  [Yellow,Green,Blue]-    -- >        index   (Yellow,Blue) Green  ==  1-    -- >        inRange (Yellow,Blue) Red    ==  False-    -- -    -- * For single-constructor datatypes, the derived instance declarations-    -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report:-    -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>.--    ) where--import GHC.Ix
− Data/Kind.hs 
@@ -1,20 +0,0 @@-{-# 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, FUN ) where--import GHC.Prim-import GHC.Types
− Data/List.hs 
@@ -1,244 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.List--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ Operations on lists.-----------------------------------------------------------------------------------module Data.List-   (-   -- * Basic functions--     (++)-   , head-   , last-   , tail-   , init-   , uncons-   , singleton-   , null-   , length--   -- * List transformations-   , map-   , reverse--   , intersperse-   , intercalate-   , transpose--   , subsequences-   , permutations--   -- * Reducing lists (folds)--   , foldl-   , foldl'-   , foldl1-   , foldl1'-   , foldr-   , foldr1--   -- ** Special folds--   , concat-   , concatMap-   , and-   , or-   , any-   , all-   , sum-   , product-   , maximum-   , minimum--   -- * Building lists--   -- ** Scans-   , scanl-   , scanl'-   , scanl1-   , scanr-   , scanr1--   -- ** Accumulating maps-   , mapAccumL-   , mapAccumR--   -- ** Infinite lists-   , iterate-   , iterate'-   , repeat-   , replicate-   , cycle--   -- ** Unfolding-   , unfoldr--   -- * Sublists--   -- ** Extracting sublists-   , take-   , drop-   , splitAt--   , takeWhile-   , dropWhile-   , dropWhileEnd-   , span-   , break--   , stripPrefix--   , group--   , inits-   , tails--   -- ** Predicates-   , isPrefixOf-   , isSuffixOf-   , isInfixOf-   , isSubsequenceOf--   -- * Searching lists--   -- ** Searching by equality-   , elem-   , notElem-   , lookup--   -- ** Searching with a predicate-   , find-   , filter-   , partition--   -- * Indexing lists-   -- | These functions treat a list @xs@ as a indexed collection,-   -- with indices ranging from 0 to @'length' xs - 1@.--   , (!!)--   , elemIndex-   , elemIndices--   , findIndex-   , findIndices--   -- * Zipping and unzipping lists--   , zip-   , zip3-   , zip4, zip5, zip6, zip7--   , zipWith-   , zipWith3-   , zipWith4, zipWith5, zipWith6, zipWith7--   , unzip-   , unzip3-   , unzip4, unzip5, unzip6, unzip7--   -- * Special lists--   -- ** Functions on strings-   , lines-   , words-   , unlines-   , unwords--   -- ** \"Set\" operations--   , nub--   , delete-   , (\\)--   , union-   , intersect--   -- ** Ordered lists-   , sort-   , sortOn-   , insert--   -- * Generalized functions--   -- ** The \"@By@\" operations-   -- | By convention, overloaded functions have a non-overloaded-   -- counterpart whose name is suffixed with \`@By@\'.-   ---   -- It is often convenient to use these functions together with-   -- 'Data.Function.on', for instance @'sortBy' ('Prelude.compare'-   -- ``Data.Function.on`` 'Prelude.fst')@.--   -- *** User-supplied equality (replacing an @Eq@ context)-   -- | The predicate is assumed to define an equivalence.-   , nubBy-   , deleteBy-   , deleteFirstsBy-   , unionBy-   , intersectBy-   , groupBy--   -- *** User-supplied comparison (replacing an @Ord@ context)-   -- | The function is assumed to define a total ordering.-   , sortBy-   , insertBy-   , maximumBy-   , minimumBy--   -- ** The \"@generic@\" operations-   -- | The prefix \`@generic@\' indicates an overloaded function that-   -- is a generalized version of a "Prelude" function.--   , genericLength-   , genericTake-   , genericDrop-   , genericSplitAt-   , genericIndex-   , genericReplicate--   ) where--import Data.Foldable-import Data.Traversable--import Data.OldList hiding ( all, and, any, concat, concatMap, elem, find,-                             foldl, foldl1, foldl', foldr, foldr1, mapAccumL,-                             mapAccumR, maximum, maximumBy, minimum, minimumBy,-                             length, notElem, null, or, product, sum )--import GHC.Base ( Bool(..), Eq((==)), otherwise )---- | 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)@.------ @since 4.8.0.0------ ==== __Examples__------ >>> isSubsequenceOf "GHC" "The Glorious Haskell Compiler"--- True--- >>> isSubsequenceOf ['a','d'..'z'] ['a'..'z']--- True--- >>> isSubsequenceOf [1..10] [10,9..0]--- False-isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool-isSubsequenceOf []    _                    = True-isSubsequenceOf _     []                   = False-isSubsequenceOf a@(x:a') (y:b) | x == y    = isSubsequenceOf a' b-                               | otherwise = isSubsequenceOf a b
− Data/List/NonEmpty.hs 
@@ -1,491 +0,0 @@-{-# 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]-   , singleton   -- :: a -> NonEmpty 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-   , append      -- :: NonEmpty a -> NonEmpty a -> NonEmpty a-   , appendList  -- :: NonEmpty a -> [a] -> NonEmpty a-   , prependList -- :: [a] -> NonEmpty 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 (Applicative (..), Alternative (many))-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           GHC.Base            (NonEmpty(..))--infixr 5 <|---- $setup--- >>> import Prelude (negate)---- | 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-{-# DEPRECATED unfold "Use unfoldr" #-}--- Deprecated in 8.2.1, remove in 8.4---- | '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---- | 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)---- | Construct a 'NonEmpty' list from a single element.------ @since 4.15-singleton :: a -> NonEmpty a-singleton a = a :| []---- | 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 = liftA2 (:|) 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 'isPrefixOf' 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"-infixl 9 !!---- | 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 occurrence 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 . toList-          . fmap 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---- | A monomorphic version of '<>' for 'NonEmpty'.------ >>> append (1 :| []) (2 :| [3])--- 1 :| [2,3]------ @since 4.16-append :: NonEmpty a -> NonEmpty a -> NonEmpty a-append = (<>)---- | Attach a list at the end of a 'NonEmpty'.------ >>> appendList (1 :| [2,3]) []--- 1 :| [2,3]------ >>> appendList (1 :| [2,3]) [4,5]--- 1 :| [2,3,4,5]------ @since 4.16-appendList :: NonEmpty a -> [a] -> NonEmpty a-appendList (x :| xs) ys = x :| xs <> ys---- | Attach a list at the beginning of a 'NonEmpty'.------ >>> prependList [] (1 :| [2,3])--- 1 :| [2,3]------ >>> prependList [negate 1, 0] (1 :| [2, 3])--- -1 :| [0,1,2,3]------ @since 4.16-prependList :: [a] -> NonEmpty a -> NonEmpty a-prependList ls ne = case ls of-  [] -> ne-  (x : xs) -> x :| xs <> toList ne
− Data/Maybe.hs 
@@ -1,305 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Maybe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ The Maybe type, and associated operations.-----------------------------------------------------------------------------------module Data.Maybe-   (-     Maybe(Nothing,Just)--   , maybe--   , isJust-   , isNothing-   , fromJust-   , fromMaybe-   , listToMaybe-   , maybeToList-   , catMaybes-   , mapMaybe-   ) where--import GHC.Base-import GHC.Stack.Types ( HasCallStack )---- $setup--- Allow the use of some Prelude functions in doctests.--- >>> import Prelude---- ------------------------------------------------------------------------------ Functions over Maybe---- | The 'maybe' function takes a default value, a function, and a 'Maybe'--- value.  If the 'Maybe' value is 'Nothing', the function returns the--- default value.  Otherwise, it applies the function to the value inside--- the 'Just' and returns the result.------ ==== __Examples__------ Basic usage:------ >>> maybe False odd (Just 3)--- True------ >>> maybe False odd Nothing--- False------ Read an integer from a string using 'Text.Read.readMaybe'. If we succeed,--- return twice the integer; that is, apply @(*2)@ to it. If instead--- we fail to parse an integer, return @0@ by default:------ >>> import Text.Read ( readMaybe )--- >>> maybe 0 (*2) (readMaybe "5")--- 10--- >>> maybe 0 (*2) (readMaybe "")--- 0------ Apply 'Prelude.show' to a @Maybe Int@. If we have @Just n@, we want to show--- the underlying 'Int' @n@. But if we have 'Nothing', we return the--- empty string instead of (for example) \"Nothing\":------ >>> maybe "" show (Just 5)--- "5"--- >>> maybe "" show Nothing--- ""----maybe :: b -> (a -> b) -> Maybe a -> b-maybe n _ Nothing  = n-maybe _ f (Just x) = f x---- | The 'isJust' function returns 'True' iff its argument is of the--- form @Just _@.------ ==== __Examples__------ Basic usage:------ >>> isJust (Just 3)--- True------ >>> isJust (Just ())--- True------ >>> isJust Nothing--- False------ Only the outer constructor is taken into consideration:------ >>> isJust (Just Nothing)--- True----isJust         :: Maybe a -> Bool-isJust Nothing = False-isJust _       = True---- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'.------ ==== __Examples__------ Basic usage:------ >>> isNothing (Just 3)--- False------ >>> isNothing (Just ())--- False------ >>> isNothing Nothing--- True------ Only the outer constructor is taken into consideration:------ >>> isNothing (Just Nothing)--- False----isNothing         :: Maybe a -> Bool-isNothing Nothing = True-isNothing _       = False---- | The 'fromJust' function extracts the element out of a 'Just' and--- throws an error if its argument is 'Nothing'.------ ==== __Examples__------ Basic usage:------ >>> fromJust (Just 1)--- 1------ >>> 2 * (fromJust (Just 10))--- 20------ >>> 2 * (fromJust Nothing)--- *** Exception: Maybe.fromJust: Nothing--- ...----fromJust          :: HasCallStack => Maybe a -> a-fromJust Nothing  = error "Maybe.fromJust: Nothing" -- yuck-fromJust (Just x) = x---- | The 'fromMaybe' function takes a default value and a 'Maybe'--- value.  If the 'Maybe' is 'Nothing', it returns the default value;--- otherwise, it returns the value contained in the 'Maybe'.------ ==== __Examples__------ Basic usage:------ >>> fromMaybe "" (Just "Hello, World!")--- "Hello, World!"------ >>> fromMaybe "" Nothing--- ""------ Read an integer from a string using 'Text.Read.readMaybe'. If we fail to--- parse an integer, we want to return @0@ by default:------ >>> import Text.Read ( readMaybe )--- >>> fromMaybe 0 (readMaybe "5")--- 5--- >>> fromMaybe 0 (readMaybe "")--- 0----fromMaybe     :: a -> Maybe a -> a-fromMaybe d x = case x of {Nothing -> d;Just v  -> v}---- | The 'maybeToList' function returns an empty list when given--- 'Nothing' or a singleton list when given 'Just'.------ ==== __Examples__------ Basic usage:------ >>> maybeToList (Just 7)--- [7]------ >>> maybeToList Nothing--- []------ One can use 'maybeToList' to avoid pattern matching when combined--- with a function that (safely) works on lists:------ >>> import Text.Read ( readMaybe )--- >>> sum $ maybeToList (readMaybe "3")--- 3--- >>> sum $ maybeToList (readMaybe "")--- 0----maybeToList            :: Maybe a -> [a]-maybeToList  Nothing   = []-maybeToList  (Just x)  = [x]---- | The 'listToMaybe' function returns 'Nothing' on an empty list--- or @'Just' a@ where @a@ is the first element of the list.------ ==== __Examples__------ Basic usage:------ >>> listToMaybe []--- Nothing------ >>> listToMaybe [9]--- Just 9------ >>> listToMaybe [1,2,3]--- Just 1------ Composing 'maybeToList' with 'listToMaybe' should be the identity--- on singleton/empty lists:------ >>> maybeToList $ listToMaybe [5]--- [5]--- >>> maybeToList $ listToMaybe []--- []------ But not on lists with more than one element:------ >>> maybeToList $ listToMaybe [1,2,3]--- [1]----listToMaybe :: [a] -> Maybe a-listToMaybe = foldr (const . Just) Nothing-{-# INLINE listToMaybe #-}--- We define listToMaybe using foldr so that it can fuse via the foldr/build--- rule. See #14387----- | The 'catMaybes' function takes a list of 'Maybe's and returns--- a list of all the 'Just' values.------ ==== __Examples__------ Basic usage:------ >>> catMaybes [Just 1, Nothing, Just 3]--- [1,3]------ When constructing a list of 'Maybe' values, 'catMaybes' can be used--- to return all of the \"success\" results (if the list is the result--- of a 'map', then 'mapMaybe' would be more appropriate):------ >>> import Text.Read ( readMaybe )--- >>> [readMaybe x :: Maybe Int | x <- ["1", "Foo", "3"] ]--- [Just 1,Nothing,Just 3]--- >>> catMaybes $ [readMaybe x :: Maybe Int | x <- ["1", "Foo", "3"] ]--- [1,3]----catMaybes :: [Maybe a] -> [a]-catMaybes = mapMaybe id -- use mapMaybe to allow fusion (#18574)---- | The 'mapMaybe' function is a version of 'map' which can throw--- out elements.  In particular, the functional argument returns--- something of type @'Maybe' b@.  If this is 'Nothing', no element--- is added on to the result list.  If it is @'Just' b@, then @b@ is--- included in the result list.------ ==== __Examples__------ Using @'mapMaybe' f x@ is a shortcut for @'catMaybes' $ 'map' f x@--- in most cases:------ >>> import Text.Read ( readMaybe )--- >>> let readMaybeInt = readMaybe :: String -> Maybe Int--- >>> mapMaybe readMaybeInt ["1", "Foo", "3"]--- [1,3]--- >>> catMaybes $ map readMaybeInt ["1", "Foo", "3"]--- [1,3]------ If we map the 'Just' constructor, the entire list should be returned:------ >>> mapMaybe Just [1,2,3]--- [1,2,3]----mapMaybe          :: (a -> Maybe b) -> [a] -> [b]-mapMaybe _ []     = []-mapMaybe f (x:xs) =- let rs = mapMaybe f xs in- case f x of-  Nothing -> rs-  Just r  -> r:rs-{-# NOINLINE [1] mapMaybe #-}--{-# RULES-"mapMaybe"     [~1] forall f xs. mapMaybe f xs-                    = build (\c n -> foldr (mapMaybeFB c f) n xs)-"mapMaybeList" [1]  forall f. foldr (mapMaybeFB (:) f) [] = mapMaybe f-  #-}--{-# INLINE [0] mapMaybeFB #-} -- See Note [Inline FB functions] in GHC.List-mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r-mapMaybeFB cons f x next = case f x of-  Nothing -> next-  Just r -> cons r next
− Data/Monoid.hs 
@@ -1,273 +0,0 @@-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE PolyKinds                  #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE Trustworthy                #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Monoid--- Copyright   :  (c) Andy Gill 2001,---                (c) Oregon Graduate Institute of Science and Technology, 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ A type @a@ is a 'Monoid' if it provides an associative function ('<>')--- that lets you combine any two values of type @a@ into one, and a neutral--- element (`mempty`) such that------ > a <> mempty == mempty <> a == a------ A 'Monoid' is a 'Semigroup' with the added requirement of a neutral element.--- Thus any 'Monoid' is a 'Semigroup', but not the other way around.------ ==== __Examples__------ The 'Sum' monoid is defined by the numerical addition operator and `0` as neutral element:------ >>> mempty :: Sum Int--- Sum {getSum = 0}--- >>> Sum 1 <> Sum 2 <> Sum 3 <> Sum 4 :: Sum Int--- Sum {getSum = 10}------ We can combine multiple values in a list into a single value using the `mconcat` function.--- Note that we have to specify the type here since 'Int' is a monoid under several different--- operations:------ >>> mconcat [1,2,3,4] :: Sum Int--- Sum {getSum = 10}--- >>> mconcat [] :: Sum Int--- Sum {getSum = 0}------ Another valid monoid instance of 'Int' is 'Product' It is defined by multiplication--- and `1` as neutral element:------ >>> Product 1 <> Product 2 <> Product 3 <> Product 4 :: Product Int--- Product {getProduct = 24}--- >>> mconcat [1,2,3,4] :: Product Int--- Product {getProduct = 24}--- >>> mconcat [] :: Product Int--- Product {getProduct = 1}--------------------------------------------------------------------------------------module Data.Monoid (-        -- * 'Monoid' typeclass-        Monoid(..),-        (<>),-        Dual(..),-        Endo(..),-        -- * 'Bool' wrappers-        All(..),-        Any(..),-        -- * 'Num' wrappers-        Sum(..),-        Product(..),-        -- * 'Maybe' wrappers-        -- $MaybeExamples-        First(..),-        Last(..),-        -- * 'Alternative' wrapper-        Alt(..),-        -- * 'Applicative' wrapper-        Ap(..)-  ) where---- Push down the module in the dependency hierarchy.-import GHC.Base hiding (Any)-import GHC.Enum-import GHC.Generics-import GHC.Num-import GHC.Read-import GHC.Show--import Control.Monad.Fail (MonadFail)--import Data.Semigroup.Internal---- $MaybeExamples--- To implement @find@ or @findLast@ on any 'Data.Foldable.Foldable':------ @--- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a--- findLast pred = getLast . foldMap (\x -> if pred x---                                            then Last (Just x)---                                            else Last Nothing)--- @------ Much of 'Data.Map.Lazy.Map's interface can be implemented with--- 'Data.Map.Lazy.alter'. Some of the rest can be implemented with a new--- 'Data.Map.Lazy.alterF' function and either 'First' or 'Last':------ > alterF :: (Functor f, Ord k) =>--- >           (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)--- >--- > instance Monoid a => Functor ((,) a)  -- from Data.Functor------ @--- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v---                     -> Map k v -> (Maybe v, Map k v)--- insertLookupWithKey combine key value =---   Arrow.first getFirst . 'Data.Map.Lazy.alterF' doChange key---   where---   doChange Nothing = (First Nothing, Just value)---   doChange (Just oldValue) =---     (First (Just oldValue),---      Just (combine key value oldValue))--- @----- | Maybe monoid returning the leftmost non-Nothing value.------ @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it--- historically.------ >>> getFirst (First (Just "hello") <> First Nothing <> First (Just "world"))--- Just "hello"-newtype First a = First { getFirst :: Maybe a }-        deriving ( Eq          -- ^ @since 2.01-                 , Ord         -- ^ @since 2.01-                 , Read        -- ^ @since 2.01-                 , Show        -- ^ @since 2.01-                 , Generic     -- ^ @since 4.7.0.0-                 , Generic1    -- ^ @since 4.7.0.0-                 , Functor     -- ^ @since 4.8.0.0-                 , Applicative -- ^ @since 4.8.0.0-                 , Monad       -- ^ @since 4.8.0.0-                 )---- | @since 4.9.0.0-instance Semigroup (First a) where-        First Nothing <> b = b-        a             <> _ = a-        stimes = stimesIdempotentMonoid---- | @since 2.01-instance Monoid (First a) where-        mempty = First Nothing---- | Maybe monoid returning the rightmost non-Nothing value.------ @'Last' a@ is isomorphic to @'Dual' ('First' a)@, and thus to--- @'Dual' ('Alt' 'Maybe' a)@------ >>> getLast (Last (Just "hello") <> Last Nothing <> Last (Just "world"))--- Just "world"-newtype Last a = Last { getLast :: Maybe a }-        deriving ( Eq          -- ^ @since 2.01-                 , Ord         -- ^ @since 2.01-                 , Read        -- ^ @since 2.01-                 , Show        -- ^ @since 2.01-                 , Generic     -- ^ @since 4.7.0.0-                 , Generic1    -- ^ @since 4.7.0.0-                 , Functor     -- ^ @since 4.8.0.0-                 , Applicative -- ^ @since 4.8.0.0-                 , Monad       -- ^ @since 4.8.0.0-                 )---- | @since 4.9.0.0-instance Semigroup (Last a) where-        a <> Last Nothing = a-        _ <> b                   = b-        stimes = stimesIdempotentMonoid---- | @since 2.01-instance Monoid (Last a) where-        mempty = Last Nothing---- | This data type witnesses the lifting of a 'Monoid' into an--- 'Applicative' pointwise.------ @since 4.12.0.0-newtype Ap f a = Ap { getAp :: f a }-        deriving ( Alternative -- ^ @since 4.12.0.0-                 , Applicative -- ^ @since 4.12.0.0-                 , Enum        -- ^ @since 4.12.0.0-                 , Eq          -- ^ @since 4.12.0.0-                 , Functor     -- ^ @since 4.12.0.0-                 , Generic     -- ^ @since 4.12.0.0-                 , Generic1    -- ^ @since 4.12.0.0-                 , Monad       -- ^ @since 4.12.0.0-                 , MonadFail   -- ^ @since 4.12.0.0-                 , MonadPlus   -- ^ @since 4.12.0.0-                 , Ord         -- ^ @since 4.12.0.0-                 , Read        -- ^ @since 4.12.0.0-                 , Show        -- ^ @since 4.12.0.0-                 )---- | @since 4.12.0.0-instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where-        (Ap x) <> (Ap y) = Ap $ liftA2 (<>) x y---- | @since 4.12.0.0-instance (Applicative f, Monoid a) => Monoid (Ap f a) where-        mempty = Ap $ pure mempty---- | @since 4.12.0.0-instance (Applicative f, Bounded a) => Bounded (Ap f a) where-  minBound = pure minBound-  maxBound = pure maxBound---- | Note that even if the underlying 'Num' and 'Applicative' instances are--- lawful, for most 'Applicative's, this instance will not be lawful. If you use--- this instance with the list 'Applicative', the following customary laws will--- not hold:------ Commutativity:------ >>> Ap [10,20] + Ap [1,2]--- Ap {getAp = [11,12,21,22]}--- >>> Ap [1,2] + Ap [10,20]--- Ap {getAp = [11,21,12,22]}------ Additive inverse:------ >>> Ap [] + negate (Ap [])--- Ap {getAp = []}--- >>> fromInteger 0 :: Ap [] Int--- Ap {getAp = [0]}------ Distributivity:------ >>> Ap [1,2] * (3 + 4)--- Ap {getAp = [7,14]}--- >>> (Ap [1,2] * 3) + (Ap [1,2] * 4)--- Ap {getAp = [7,11,10,14]}------ @since 4.12.0.0-instance (Applicative f, Num a) => Num (Ap f a) where-  (+)         = liftA2 (+)-  (*)         = liftA2 (*)-  negate      = fmap negate-  fromInteger = pure . fromInteger-  abs         = fmap abs-  signum      = fmap signum--{--{---------------------------------------------------------------------  Testing---------------------------------------------------------------------}-instance Arbitrary a => Arbitrary (Maybe a) where-  arbitrary = oneof [return Nothing, Just `fmap` arbitrary]--prop_mconcatMaybe :: [Maybe [Int]] -> Bool-prop_mconcatMaybe x =-  fromMaybe [] (mconcat x) == mconcat (catMaybes x)--prop_mconcatFirst :: [Maybe Int] -> Bool-prop_mconcatFirst x =-  getFirst (mconcat (map First x)) == listToMaybe (catMaybes x)-prop_mconcatLast :: [Maybe Int] -> Bool-prop_mconcatLast x =-  getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x)-        where listLastToMaybe [] = Nothing-              listLastToMaybe lst = Just (last lst)--- -}---- $setup--- >>> import Prelude
− Data/OldList.hs 
@@ -1,1556 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables,-             MagicHash, BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  Data.List--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ Operations on lists.-----------------------------------------------------------------------------------module Data.OldList-   (-   -- * Basic functions--     (++)-   , head-   , last-   , tail-   , init-   , uncons-   , singleton-   , null-   , length--   -- * List transformations-   , map-   , reverse--   , intersperse-   , intercalate-   , transpose--   , subsequences-   , permutations--   -- * Reducing lists (folds)--   , foldl-   , foldl'-   , foldl1-   , foldl1'-   , foldr-   , foldr1--   -- ** Special folds--   , concat-   , concatMap-   , and-   , or-   , any-   , all-   , sum-   , product-   , maximum-   , minimum--   -- * Building lists--   -- ** Scans-   , scanl-   , scanl'-   , scanl1-   , scanr-   , scanr1--   -- ** Accumulating maps-   , mapAccumL-   , mapAccumR--   -- ** Infinite lists-   , iterate-   , iterate'-   , repeat-   , replicate-   , cycle--   -- ** Unfolding-   , unfoldr--   -- * Sublists--   -- ** Extracting sublists-   , take-   , drop-   , splitAt--   , takeWhile-   , dropWhile-   , dropWhileEnd-   , span-   , break--   , stripPrefix--   , group--   , inits-   , tails--   -- ** Predicates-   , isPrefixOf-   , isSuffixOf-   , isInfixOf--   -- * Searching lists--   -- ** Searching by equality-   , elem-   , notElem-   , lookup--   -- ** Searching with a predicate-   , find-   , filter-   , partition--   -- * Indexing lists-   -- | These functions treat a list @xs@ as a indexed collection,-   -- with indices ranging from 0 to @'length' xs - 1@.--   , (!!)--   , elemIndex-   , elemIndices--   , findIndex-   , findIndices--   -- * Zipping and unzipping lists--   , zip-   , zip3-   , zip4, zip5, zip6, zip7--   , zipWith-   , zipWith3-   , zipWith4, zipWith5, zipWith6, zipWith7--   , unzip-   , unzip3-   , unzip4, unzip5, unzip6, unzip7--   -- * Special lists--   -- ** Functions on strings-   , lines-   , words-   , unlines-   , unwords--   -- ** \"Set\" operations--   , nub--   , delete-   , (\\)--   , union-   , intersect--   -- ** Ordered lists-   , sort-   , sortOn-   , insert--   -- * Generalized functions--   -- ** The \"@By@\" operations-   -- | By convention, overloaded functions have a non-overloaded-   -- counterpart whose name is suffixed with \`@By@\'.-   ---   -- It is often convenient to use these functions together with-   -- 'Data.Function.on', for instance @'sortBy' ('compare'-   -- \`on\` 'fst')@.--   -- *** User-supplied equality (replacing an @Eq@ context)-   -- | The predicate is assumed to define an equivalence.-   , nubBy-   , deleteBy-   , deleteFirstsBy-   , unionBy-   , intersectBy-   , groupBy--   -- *** User-supplied comparison (replacing an @Ord@ context)-   -- | The function is assumed to define a total ordering.-   , sortBy-   , insertBy-   , maximumBy-   , minimumBy--   -- ** The \"@generic@\" operations-   -- | The prefix \`@generic@\' indicates an overloaded function that-   -- is a generalized version of a "Prelude" function.--   , genericLength-   , genericTake-   , genericDrop-   , genericSplitAt-   , genericIndex-   , genericReplicate--   ) where--import Data.Maybe-import Data.Bits        ( (.&.) )-import Data.Char        ( isSpace )-import Data.Ord         ( comparing )-import Data.Tuple       ( fst, snd )--import GHC.Num-import GHC.Real-import GHC.List-import GHC.Base--infix 5 \\ -- comment to fool cpp: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#cpp-and-string-gaps---- -------------------------------------------------------------------------------- List functions---- | The 'dropWhileEnd' function drops the largest suffix of a list--- in which the given predicate holds for all elements.  For example:------ >>> dropWhileEnd isSpace "foo\n"--- "foo"------ >>> dropWhileEnd isSpace "foo bar"--- "foo bar"------ > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined------ @since 4.5.0.0-dropWhileEnd :: (a -> Bool) -> [a] -> [a]-dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []---- | \(\mathcal{O}(\min(m,n))\). The 'stripPrefix' function drops the given--- prefix from a list. It returns 'Nothing' if the list did not start with the--- prefix given, or 'Just' the list after the prefix, if it does.------ >>> stripPrefix "foo" "foobar"--- Just "bar"------ >>> stripPrefix "foo" "foo"--- Just ""------ >>> stripPrefix "foo" "barfoo"--- Nothing------ >>> stripPrefix "foo" "barfoobaz"--- Nothing-stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]-stripPrefix [] ys = Just ys-stripPrefix (x:xs) (y:ys)- | x == y = stripPrefix xs ys-stripPrefix _ _ = Nothing---- | The 'elemIndex' function returns the index of the first element--- in the given list which is equal (by '==') to the query element,--- or 'Nothing' if there is no such element.------ >>> elemIndex 4 [0..]--- Just 4-elemIndex       :: Eq a => a -> [a] -> Maybe Int-elemIndex x     = findIndex (x==)---- | The 'elemIndices' function extends 'elemIndex', by returning the--- indices of all elements equal to the query element, in ascending order.------ >>> elemIndices 'o' "Hello World"--- [4,7]-elemIndices     :: Eq a => a -> [a] -> [Int]-elemIndices x   = findIndices (x==)---- | The 'find' function takes a predicate and a list and returns the--- first element in the list matching the predicate, or 'Nothing' if--- there is no such element.------ >>> find (> 4) [1..]--- Just 5------ >>> find (< 0) [1..10]--- Nothing-find            :: (a -> Bool) -> [a] -> Maybe a-find p          = listToMaybe . filter p---- | The 'findIndex' function takes a predicate and a list and returns--- the index of the first element in the list satisfying the predicate,--- or 'Nothing' if there is no such element.------ >>> findIndex isSpace "Hello World!"--- Just 5-findIndex       :: (a -> Bool) -> [a] -> Maybe Int-findIndex p     = listToMaybe . findIndices p---- | The 'findIndices' function extends 'findIndex', by returning the--- indices of all elements satisfying the predicate, in ascending order.------ >>> findIndices (`elem` "aeiou") "Hello World!"--- [1,4,7]-findIndices      :: (a -> Bool) -> [a] -> [Int]-#if defined(USE_REPORT_PRELUDE)-findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]-#else--- Efficient definition, adapted from Data.Sequence--- (Note that making this INLINABLE instead of INLINE allows--- 'findIndex' to fuse, fixing #15426.)-{-# INLINABLE findIndices #-}-findIndices p ls = build $ \c n ->-  let go x r k | p x       = I# k `c` r (k +# 1#)-               | otherwise = r (k +# 1#)-  in foldr go (\_ -> n) ls 0#-#endif  /* USE_REPORT_PRELUDE */---- | \(\mathcal{O}(\min(m,n))\). The 'isPrefixOf' function takes two lists and--- returns 'True' iff the first list is a prefix of the second.------ >>> "Hello" `isPrefixOf` "Hello World!"--- True------ >>> "Hello" `isPrefixOf` "Wello Horld!"--- False-isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool-isPrefixOf [] _         =  True-isPrefixOf _  []        =  False-isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys---- | The 'isSuffixOf' function takes two lists and returns 'True' iff--- the first list is a suffix of the second. The second list must be--- finite.------ >>> "ld!" `isSuffixOf` "Hello World!"--- True------ >>> "World" `isSuffixOf` "Hello World!"--- False-isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool-ns `isSuffixOf` hs      = maybe False id $ do-      delta <- dropLengthMaybe ns hs-      return $ ns == dropLength delta hs-      -- Since dropLengthMaybe ns hs succeeded, we know that (if hs is finite)-      -- length ns + length delta = length hs-      -- so dropping the length of delta from hs will yield a suffix exactly-      -- the length of ns.---- A version of drop that drops the length of the first argument from the--- second argument. If xs is longer than ys, xs will not be traversed in its--- entirety.  dropLength is also generally faster than (drop . length)--- Both this and dropLengthMaybe could be written as folds over their first--- arguments, but this reduces clarity with no benefit to isSuffixOf.------ >>> dropLength "Hello" "Holla world"--- " world"------ >>> dropLength [1..] [1,2,3]--- []-dropLength :: [a] -> [b] -> [b]-dropLength [] y = y-dropLength _ [] = []-dropLength (_:x') (_:y') = dropLength x' y'---- A version of dropLength that returns Nothing if the second list runs out of--- elements before the first.------ >>> dropLengthMaybe [1..] [1,2,3]--- Nothing-dropLengthMaybe :: [a] -> [b] -> Maybe [b]-dropLengthMaybe [] y = Just y-dropLengthMaybe _ [] = Nothing-dropLengthMaybe (_:x') (_:y') = dropLengthMaybe x' y'---- | The 'isInfixOf' function takes two lists and returns 'True'--- iff the first list is contained, wholly and intact,--- anywhere within the second.------ >>> isInfixOf "Haskell" "I really like Haskell."--- True------ >>> isInfixOf "Ial" "I really like Haskell."--- False-isInfixOf               :: (Eq a) => [a] -> [a] -> Bool-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)---- | \(\mathcal{O}(n^2)\). The 'nub' function removes duplicate elements from a--- list. In particular, it keeps only the first occurrence of each element. (The--- name 'nub' means \`essence\'.) It is a special case of 'nubBy', which allows--- the programmer to supply their own equality test.------ >>> nub [1,2,3,4,3,2,1,2,4,3,5]--- [1,2,3,4,5]-nub                     :: (Eq a) => [a] -> [a]-nub                     =  nubBy (==)---- | The 'nubBy' function behaves just like 'nub', except it uses a--- user-supplied equality predicate instead of the overloaded '=='--- function.------ >>> nubBy (\x y -> mod x 3 == mod y 3) [1,2,4,5,6]--- [1,2,6]-nubBy                   :: (a -> a -> Bool) -> [a] -> [a]-#if defined(USE_REPORT_PRELUDE)-nubBy eq []             =  []-nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs)-#else--- stolen from HBC-nubBy eq l              = nubBy' l []-  where-    nubBy' [] _         = []-    nubBy' (y:ys) xs-       | elem_by eq y xs = nubBy' ys xs-       | otherwise       = y : nubBy' ys (y:xs)---- Not exported:--- Note that we keep the call to `eq` with arguments in the--- same order as in the reference (prelude) implementation,--- and that this order is different from how `elem` calls (==).--- See #2528, #3280 and #7913.--- 'xs' is the list of things we've seen so far,--- 'y' is the potential new element-elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool-elem_by _  _ []         =  False-elem_by eq y (x:xs)     =  x `eq` y || elem_by eq y xs-#endif----- | \(\mathcal{O}(n)\). 'delete' @x@ removes the first occurrence of @x@ from--- its list argument. For example,------ >>> delete 'a' "banana"--- "bnana"------ It is a special case of 'deleteBy', which allows the programmer to--- supply their own equality test.-delete                  :: (Eq a) => a -> [a] -> [a]-delete                  =  deleteBy (==)---- | \(\mathcal{O}(n)\). The 'deleteBy' function behaves like 'delete', but--- takes a user-supplied equality predicate.------ >>> deleteBy (<=) 4 [1..10]--- [1,2,3,5,6,7,8,9,10]-deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]-deleteBy _  _ []        = []-deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys---- | The '\\' function is list difference (non-associative).--- In the result of @xs@ '\\' @ys@, the first occurrence of each element of--- @ys@ in turn (if any) has been removed from @xs@.  Thus------ > (xs ++ ys) \\ xs == ys.------ >>> "Hello World!" \\ "ell W"--- "Hoorld!"------ It is a special case of 'deleteFirstsBy', which allows the programmer--- to supply their own equality test.--(\\)                    :: (Eq a) => [a] -> [a] -> [a]-(\\)                    =  foldl (flip delete)---- | The 'union' function returns the list union of the two lists.--- For example,------ >>> "dog" `union` "cow"--- "dogcw"------ Duplicates, and elements of the first list, are removed from the--- the second list, but if the first list contains duplicates, so will--- the result.--- It is a special case of 'unionBy', which allows the programmer to supply--- their own equality test.--union                   :: (Eq a) => [a] -> [a] -> [a]-union                   = unionBy (==)---- | The 'unionBy' function is the non-overloaded version of 'union'.-unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]-unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs---- | The 'intersect' function takes the list intersection of two lists.--- For example,------ >>> [1,2,3,4] `intersect` [2,4,6,8]--- [2,4]------ If the first list contains duplicates, so will the result.------ >>> [1,2,2,3,4] `intersect` [6,4,4,2]--- [2,2,4]------ It is a special case of 'intersectBy', which allows the programmer to--- supply their own equality test. If the element is found in both the first--- and the second list, the element from the first list will be used.--intersect               :: (Eq a) => [a] -> [a] -> [a]-intersect               =  intersectBy (==)---- | The 'intersectBy' function is the non-overloaded version of 'intersect'.-intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]-intersectBy _  [] _     =  []-intersectBy _  _  []    =  []-intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]---- | \(\mathcal{O}(n)\). The 'intersperse' function takes an element and a list--- and \`intersperses\' that element between the elements of the list. For--- example,------ >>> intersperse ',' "abcde"--- "a,b,c,d,e"-intersperse             :: a -> [a] -> [a]-intersperse _   []      = []-intersperse sep (x:xs)  = x : prependToAll sep xs----- Not exported:--- We want to make every element in the 'intersperse'd list available--- as soon as possible to avoid space leaks. Experiments suggested that--- a separate top-level helper is more efficient than a local worker.-prependToAll            :: a -> [a] -> [a]-prependToAll _   []     = []-prependToAll sep (x:xs) = sep : x : prependToAll sep xs---- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@.--- It inserts the list @xs@ in between the lists in @xss@ and concatenates the--- result.------ >>> intercalate ", " ["Lorem", "ipsum", "dolor"]--- "Lorem, ipsum, dolor"-intercalate :: [a] -> [[a]] -> [a]-intercalate xs xss = concat (intersperse xs xss)---- | The 'transpose' function transposes the rows and columns of its argument.--- For example,------ >>> transpose [[1,2,3],[4,5,6]]--- [[1,4],[2,5],[3,6]]------ If some of the rows are shorter than the following rows, their elements are skipped:------ >>> transpose [[10,11],[20],[],[30,31,32]]--- [[10,20,30],[11,31],[32]]-transpose :: [[a]] -> [[a]]-transpose [] = []-transpose ([] : xss) = transpose xss-transpose ((x : xs) : xss) = combine x hds xs tls-  where-    -- We tie the calculations of heads and tails together-    -- to prevent heads from leaking into tails and vice versa.-    -- unzip makes the selector thunk arrangements we need to-    -- ensure everything gets cleaned up properly.-    (hds, tls) = unzip [(hd, tl) | hd : tl <- xss]-    combine y h ys t = (y:h) : transpose (ys:t)-    {-# NOINLINE combine #-}-  {- Implementation note:-  If the bottom part of the function was written as such:--  ```-  transpose ((x : xs) : xss) = (x:hds) : transpose (xs:tls)-  where-    (hds,tls) = hdstls-    hdstls = unzip [(hd, tl) | hd : tl <- xss]-    {-# NOINLINE hdstls #-}-  ```-  Here are the steps that would take place:--  1. We allocate a thunk, `hdstls`, representing the result of unzipping.-  2. We allocate selector thunks, `hds` and `tls`, that deconstruct `hdstls`.-  3. Install `hds` as the tail of the result head and pass `xs:tls` to-     the recursive call in the result tail.--  Once optimised, this code would amount to:--  ```-  transpose ((x : xs) : xss) = (x:hds) : (let tls = snd hdstls in transpose (xs:tls))-  where-    hds = fst hdstls-    hdstls = unzip [(hd, tl) | hd : tl <- xss]-    {-# NOINLINE hdstls #-}-  ```--  In particular, GHC does not produce the `tls` selector thunk immediately;-  rather, it waits to do so until the tail of the result is actually demanded.-  So when `hds` is demanded, that does not resolve `snd hdstls`; the tail of the-  result keeps `hdstls` alive.--  By writing `combine` and making it NOINLINE, we prevent GHC from delaying-  the selector thunk allocation, requiring that `hds` and `tls` are actually-  allocated to be passed to `combine`.-  -}----- | The 'partition' function takes a predicate and a list, and returns--- the pair of lists of elements which do and do not satisfy the--- predicate, respectively; i.e.,------ > partition p xs == (filter p xs, filter (not . p) xs)------ >>> partition (`elem` "aeiou") "Hello World!"--- ("eoo","Hll Wrld!")-partition               :: (a -> Bool) -> [a] -> ([a],[a])-{-# INLINE partition #-}-partition p xs = foldr (select p) ([],[]) xs--select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])-select p x ~(ts,fs) | p x       = (x:ts,fs)-                    | otherwise = (ts, x:fs)---- | The 'mapAccumL' function behaves like a combination of 'map' and--- 'foldl'; it applies a function to each element of a list, passing--- an accumulating parameter from left to right, and returning a final--- value of this accumulator together with the new list.-mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list-                                    -- and accumulator, returning new-                                    -- accumulator and elt of result list-          -> acc            -- Initial accumulator-          -> [x]            -- Input list-          -> (acc, [y])     -- Final accumulator and result list-{-# NOINLINE [1] mapAccumL #-}-mapAccumL _ s []        =  (s, [])-mapAccumL f s (x:xs)    =  (s'',y:ys)-                           where (s', y ) = f s x-                                 (s'',ys) = mapAccumL f s' xs--{-# RULES-"mapAccumL" [~1] forall f s xs . mapAccumL f s xs = foldr (mapAccumLF f) pairWithNil xs s-"mapAccumLList" [1] forall f s xs . foldr (mapAccumLF f) pairWithNil xs s = mapAccumL f s xs- #-}--pairWithNil :: acc -> (acc, [y])-{-# INLINE [0] pairWithNil #-}-pairWithNil x = (x, [])--mapAccumLF :: (acc -> x -> (acc, y)) -> x -> (acc -> (acc, [y])) -> acc -> (acc, [y])-{-# INLINE [0] mapAccumLF #-}-mapAccumLF f = \x r -> oneShot (\s ->-                         let (s', y)   = f s x-                             (s'', ys) = r s'-                         in (s'', y:ys))-  -- See Note [Left folds via right fold]----- | The 'mapAccumR' function behaves like a combination of 'map' and--- 'foldr'; it applies a function to each element of a list, passing--- an accumulating parameter from right to left, and returning a final--- value of this accumulator together with the new list.-mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list-                                        -- and accumulator, returning new-                                        -- accumulator and elt of result list-            -> acc              -- Initial accumulator-            -> [x]              -- Input list-            -> (acc, [y])               -- Final accumulator and result list-mapAccumR _ s []        =  (s, [])-mapAccumR f s (x:xs)    =  (s'', y:ys)-                           where (s'',y ) = f s' x-                                 (s', ys) = mapAccumR f s xs---- | \(\mathcal{O}(n)\). The 'insert' function takes an element and a list and--- inserts the element into the list at the first position where it is less than--- or equal to the next element. In particular, if the list is sorted before the--- call, the result will also be sorted. It is a special case of 'insertBy',--- which allows the programmer to supply their own comparison function.------ >>> insert 4 [1,2,3,5,6,7]--- [1,2,3,4,5,6,7]-insert :: Ord a => a -> [a] -> [a]-insert e ls = insertBy (compare) e ls---- | \(\mathcal{O}(n)\). The non-overloaded version of 'insert'.-insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]-insertBy _   x [] = [x]-insertBy cmp x ys@(y:ys')- = case cmp x y of-     GT -> y : insertBy cmp x ys'-     _  -> x : ys---- | The 'maximumBy' function takes a comparison function and a list--- and returns the greatest element of the list by the comparison function.--- The list must be finite and non-empty.------ We can use this to find the longest entry of a list:------ >>> maximumBy (\x y -> compare (length x) (length y)) ["Hello", "World", "!", "Longest", "bar"]--- "Longest"-maximumBy               :: (a -> a -> Ordering) -> [a] -> a-maximumBy _ []          =  errorWithoutStackTrace "List.maximumBy: empty list"-maximumBy cmp xs        =  foldl1 maxBy xs-                        where-                           maxBy x y = case cmp x y of-                                       GT -> x-                                       _  -> y---- | The 'minimumBy' function takes a comparison function and a list--- and returns the least element of the list by the comparison function.--- The list must be finite and non-empty.------ We can use this to find the shortest entry of a list:------ >>> minimumBy (\x y -> compare (length x) (length y)) ["Hello", "World", "!", "Longest", "bar"]--- "!"-minimumBy               :: (a -> a -> Ordering) -> [a] -> a-minimumBy _ []          =  errorWithoutStackTrace "List.minimumBy: empty list"-minimumBy cmp xs        =  foldl1 minBy xs-                        where-                           minBy x y = case cmp x y of-                                       GT -> y-                                       _  -> x---- | \(\mathcal{O}(n)\). The 'genericLength' function is an overloaded version--- of 'length'. In particular, instead of returning an 'Int', it returns any--- type which is an instance of 'Num'. It is, however, less efficient than--- 'length'.------ >>> genericLength [1, 2, 3] :: Int--- 3--- >>> genericLength [1, 2, 3] :: Float--- 3.0-genericLength           :: (Num i) => [a] -> i-{-# NOINLINE [1] genericLength #-}-genericLength []        =  0-genericLength (_:l)     =  1 + genericLength l--{-# RULES-  "genericLengthInt"     genericLength = (strictGenericLength :: [a] -> Int);-  "genericLengthInteger" genericLength = (strictGenericLength :: [a] -> Integer);- #-}--strictGenericLength     :: (Num i) => [b] -> i-strictGenericLength l   =  gl l 0-                        where-                           gl [] a     = a-                           gl (_:xs) a = let a' = a + 1 in a' `seq` gl xs a'---- | The 'genericTake' function is an overloaded version of 'take', which--- accepts any 'Integral' value as the number of elements to take.-genericTake             :: (Integral i) => i -> [a] -> [a]-genericTake n _ | n <= 0 = []-genericTake _ []        =  []-genericTake n (x:xs)    =  x : genericTake (n-1) xs---- | The 'genericDrop' function is an overloaded version of 'drop', which--- accepts any 'Integral' value as the number of elements to drop.-genericDrop             :: (Integral i) => i -> [a] -> [a]-genericDrop n xs | n <= 0 = xs-genericDrop _ []        =  []-genericDrop n (_:xs)    =  genericDrop (n-1) xs----- | The 'genericSplitAt' function is an overloaded version of 'splitAt', which--- accepts any 'Integral' value as the position at which to split.-genericSplitAt          :: (Integral i) => i -> [a] -> ([a], [a])-genericSplitAt n xs | n <= 0 =  ([],xs)-genericSplitAt _ []     =  ([],[])-genericSplitAt n (x:xs) =  (x:xs',xs'') where-    (xs',xs'') = genericSplitAt (n-1) xs---- | The 'genericIndex' function is an overloaded version of '!!', which--- accepts any 'Integral' value as the index.-genericIndex :: (Integral i) => [a] -> i -> a-genericIndex (x:_)  0 = x-genericIndex (_:xs) n- | n > 0     = genericIndex xs (n-1)- | 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.-genericReplicate        :: (Integral i) => i -> a -> [a]-genericReplicate n x    =  genericTake n (repeat x)---- | The 'zip4' function takes four lists and returns a list of--- quadruples, analogous to 'zip'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# INLINE zip4 #-}-zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]-zip4                    =  zipWith4 (,,,)---- | The 'zip5' function takes five lists and returns a list of--- five-tuples, analogous to 'zip'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# INLINE zip5 #-}-zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]-zip5                    =  zipWith5 (,,,,)---- | The 'zip6' function takes six lists and returns a list of six-tuples,--- analogous to 'zip'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# INLINE zip6 #-}-zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->-                              [(a,b,c,d,e,f)]-zip6                    =  zipWith6 (,,,,,)---- | The 'zip7' function takes seven lists and returns a list of--- seven-tuples, analogous to 'zip'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# INLINE zip7 #-}-zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->-                              [g] -> [(a,b,c,d,e,f,g)]-zip7                    =  zipWith7 (,,,,,,)---- | The 'zipWith4' function takes a function which combines four--- elements, as well as four lists and returns a list of their point-wise--- combination, analogous to 'zipWith'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zipWith4 #-}-zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]-zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)-                        =  z a b c d : zipWith4 z as bs cs ds-zipWith4 _ _ _ _ _      =  []---- | The 'zipWith5' function takes a function which combines five--- elements, as well as five lists and returns a list of their point-wise--- combination, analogous to 'zipWith'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zipWith5 #-}-zipWith5                :: (a->b->c->d->e->f) ->-                           [a]->[b]->[c]->[d]->[e]->[f]-zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)-                        =  z a b c d e : zipWith5 z as bs cs ds es-zipWith5 _ _ _ _ _ _    = []---- | The 'zipWith6' function takes a function which combines six--- elements, as well as six lists and returns a list of their point-wise--- combination, analogous to 'zipWith'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zipWith6 #-}-zipWith6                :: (a->b->c->d->e->f->g) ->-                           [a]->[b]->[c]->[d]->[e]->[f]->[g]-zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)-                        =  z a b c d e f : zipWith6 z as bs cs ds es fs-zipWith6 _ _ _ _ _ _ _  = []---- | The 'zipWith7' function takes a function which combines seven--- elements, as well as seven lists and returns a list of their point-wise--- combination, analogous to 'zipWith'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zipWith7 #-}-zipWith7                :: (a->b->c->d->e->f->g->h) ->-                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]-zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)-                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs-zipWith7 _ _ _ _ _ _ _ _ = []--{--Functions and rules for fusion of zipWith4, zipWith5, zipWith6 and zipWith7.-The principle is the same as for zip and zipWith in GHC.List:-Turn zipWithX into a version in which the first argument and the result-can be fused. Turn it back into the original function if no fusion happens.--}--{-# INLINE [0] zipWith4FB #-} -- See Note [Inline FB functions]-zipWith4FB :: (e->xs->xs') -> (a->b->c->d->e) ->-              a->b->c->d->xs->xs'-zipWith4FB cons func = \a b c d r -> (func a b c d) `cons` r--{-# INLINE [0] zipWith5FB #-} -- See Note [Inline FB functions]-zipWith5FB :: (f->xs->xs') -> (a->b->c->d->e->f) ->-              a->b->c->d->e->xs->xs'-zipWith5FB cons func = \a b c d e r -> (func a b c d e) `cons` r--{-# INLINE [0] zipWith6FB #-} -- See Note [Inline FB functions]-zipWith6FB :: (g->xs->xs') -> (a->b->c->d->e->f->g) ->-              a->b->c->d->e->f->xs->xs'-zipWith6FB cons func = \a b c d e f r -> (func a b c d e f) `cons` r--{-# INLINE [0] zipWith7FB #-} -- See Note [Inline FB functions]-zipWith7FB :: (h->xs->xs') -> (a->b->c->d->e->f->g->h) ->-              a->b->c->d->e->f->g->xs->xs'-zipWith7FB cons func = \a b c d e f g r -> (func a b c d e f g) `cons` r--{-# INLINE [0] foldr4 #-}-foldr4 :: (a->b->c->d->e->e) ->-          e->[a]->[b]->[c]->[d]->e-foldr4 k z = go-  where-    go (a:as) (b:bs) (c:cs) (d:ds) = k a b c d (go as bs cs ds)-    go _      _      _      _      = z--{-# INLINE [0] foldr5 #-}-foldr5 :: (a->b->c->d->e->f->f) ->-          f->[a]->[b]->[c]->[d]->[e]->f-foldr5 k z = go-  where-    go (a:as) (b:bs) (c:cs) (d:ds) (e:es) = k a b c d e (go as bs cs ds es)-    go _      _      _      _      _      = z--{-# INLINE [0] foldr6 #-}-foldr6 :: (a->b->c->d->e->f->g->g) ->-          g->[a]->[b]->[c]->[d]->[e]->[f]->g-foldr6 k z = go-  where-    go (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = k a b c d e f (-        go as bs cs ds es fs)-    go _      _      _      _      _      _      = z--{-# INLINE [0] foldr7 #-}-foldr7 :: (a->b->c->d->e->f->g->h->h) ->-          h->[a]->[b]->[c]->[d]->[e]->[f]->[g]->h-foldr7 k z = go-  where-    go (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = k a b c d e f g (-        go as bs cs ds es fs gs)-    go _      _      _      _      _      _      _      = z--foldr4_left :: (a->b->c->d->e->f)->-               f->a->([b]->[c]->[d]->e)->-               [b]->[c]->[d]->f-foldr4_left k _z a r (b:bs) (c:cs) (d:ds) = k a b c d (r bs cs ds)-foldr4_left _  z _ _ _      _      _      = z--foldr5_left :: (a->b->c->d->e->f->g)->-               g->a->([b]->[c]->[d]->[e]->f)->-               [b]->[c]->[d]->[e]->g-foldr5_left k _z a r (b:bs) (c:cs) (d:ds) (e:es) = k a b c d e (r bs cs ds es)-foldr5_left _  z _ _ _      _      _      _      = z--foldr6_left :: (a->b->c->d->e->f->g->h)->-               h->a->([b]->[c]->[d]->[e]->[f]->g)->-               [b]->[c]->[d]->[e]->[f]->h-foldr6_left k _z a r (b:bs) (c:cs) (d:ds) (e:es) (f:fs) =-    k a b c d e f (r bs cs ds es fs)-foldr6_left _  z _ _ _      _      _      _      _      = z--foldr7_left :: (a->b->c->d->e->f->g->h->i)->-               i->a->([b]->[c]->[d]->[e]->[f]->[g]->h)->-               [b]->[c]->[d]->[e]->[f]->[g]->i-foldr7_left k _z a r (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) =-    k a b c d e f g (r bs cs ds es fs gs)-foldr7_left _  z _ _ _      _      _      _      _      _      = z--{-# RULES--"foldr4/left"   forall k z (g::forall b.(a->b->b)->b->b).-                  foldr4 k z (build g) = g (foldr4_left k z) (\_ _ _ -> z)-"foldr5/left"   forall k z (g::forall b.(a->b->b)->b->b).-                  foldr5 k z (build g) = g (foldr5_left k z) (\_ _ _ _ -> z)-"foldr6/left"   forall k z (g::forall b.(a->b->b)->b->b).-                  foldr6 k z (build g) = g (foldr6_left k z) (\_ _ _ _ _ -> z)-"foldr7/left"   forall k z (g::forall b.(a->b->b)->b->b).-                  foldr7 k z (build g) = g (foldr7_left k z) (\_ _ _ _ _ _ -> z)--"zipWith4" [~1] forall f as bs cs ds.-                  zipWith4 f as bs cs ds = build (\c n ->-                        foldr4 (zipWith4FB c f) n as bs cs ds)-"zipWith5" [~1] forall f as bs cs ds es.-                  zipWith5 f as bs cs ds es = build (\c n ->-                        foldr5 (zipWith5FB c f) n as bs cs ds es)-"zipWith6" [~1] forall f as bs cs ds es fs.-                  zipWith6 f as bs cs ds es fs = build (\c n ->-                        foldr6 (zipWith6FB c f) n as bs cs ds es fs)-"zipWith7" [~1] forall f as bs cs ds es fs gs.-                  zipWith7 f as bs cs ds es fs gs = build (\c n ->-                        foldr7 (zipWith7FB c f) n as bs cs ds es fs gs)--"zipWith4List"  [1]  forall f.   foldr4 (zipWith4FB (:) f) [] = zipWith4 f-"zipWith5List"  [1]  forall f.   foldr5 (zipWith5FB (:) f) [] = zipWith5 f-"zipWith6List"  [1]  forall f.   foldr6 (zipWith6FB (:) f) [] = zipWith6 f-"zipWith7List"  [1]  forall f.   foldr7 (zipWith7FB (:) f) [] = zipWith7 f-- #-}--{---Note [Inline @unzipN@ functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The inline principle for @unzip{4,5,6,7}@ is the same as 'unzip'/'unzip3' in-"GHC.List".-The 'unzip'/'unzip3' functions are inlined so that the `foldr` with which they-are defined has an opportunity to fuse.--As such, since there are not any differences between 2/3-ary 'unzip' and its-n-ary counterparts below aside from the number of arguments, the `INLINE`-pragma should be replicated in the @unzipN@ functions below as well.---}---- | The 'unzip4' function takes a list of quadruples and returns four--- lists, analogous to 'unzip'.-{-# INLINE unzip4 #-}--- Inline so that fusion with `foldr` has an opportunity to fire.--- See Note [Inline @unzipN@ functions] above.-unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])-unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->-                                        (a:as,b:bs,c:cs,d:ds))-                                 ([],[],[],[])---- | The 'unzip5' function takes a list of five-tuples and returns five--- lists, analogous to 'unzip'.-{-# INLINE unzip5 #-}--- Inline so that fusion with `foldr` has an opportunity to fire.--- See Note [Inline @unzipN@ functions] above.-unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])-unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->-                                        (a:as,b:bs,c:cs,d:ds,e:es))-                                 ([],[],[],[],[])---- | The 'unzip6' function takes a list of six-tuples and returns six--- lists, analogous to 'unzip'.-{-# INLINE unzip6 #-}--- Inline so that fusion with `foldr` has an opportunity to fire.--- See Note [Inline @unzipN@ functions] above.-unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])-unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->-                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))-                                 ([],[],[],[],[],[])---- | The 'unzip7' function takes a list of seven-tuples and returns--- seven lists, analogous to 'unzip'.-{-# INLINE unzip7 #-}--- Inline so that fusion with `foldr` has an opportunity to fire.--- See Note [Inline @unzipN@ functions] above.-unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])-unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->-                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))-                         ([],[],[],[],[],[],[])----- | The 'deleteFirstsBy' function takes a predicate and two lists and--- returns the first list with the first occurrence of each element of--- the second list removed.-deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]-deleteFirstsBy eq       =  foldl (flip (deleteBy eq))---- | The 'group' function takes a list and returns a list of lists such--- that the concatenation of the result is equal to the argument.  Moreover,--- each sublist in the result contains only equal elements.  For example,------ >>> group "Mississippi"--- ["M","i","ss","i","ss","i","pp","i"]------ It is a special case of 'groupBy', which allows the programmer to supply--- their own equality test.-group                   :: Eq a => [a] -> [[a]]-group                   =  groupBy (==)---- | The 'groupBy' function is the non-overloaded version of 'group'.-groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]-groupBy _  []           =  []-groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs-                           where (ys,zs) = span (eq x) xs---- | The 'inits' function returns all initial segments of the argument,--- shortest first.  For example,------ >>> inits "abc"--- ["","a","ab","abc"]------ Note that 'inits' has the following strictness property:--- @inits (xs ++ _|_) = inits xs ++ _|_@------ In particular,--- @inits _|_ = [] : _|_@-inits                   :: [a] -> [[a]]-inits                   = map toListSB . scanl' snocSB emptySB-{-# NOINLINE inits #-}---- We do not allow inits to inline, because it plays havoc with Call Arity--- if it fuses with a consumer, and it would generally lead to serious--- loss of sharing if allowed to fuse with a producer.---- | \(\mathcal{O}(n)\). The 'tails' function returns all final segments of the--- argument, longest first. For example,------ >>> tails "abc"--- ["abc","bc","c",""]------ Note that 'tails' has the following strictness property:--- @tails _|_ = _|_ : _|_@-tails                   :: [a] -> [[a]]-{-# INLINABLE tails #-}-tails lst               =  build (\c n ->-  let tailsGo xs = xs `c` case xs of-                             []      -> n-                             _ : xs' -> tailsGo xs'-  in tailsGo lst)---- | The 'subsequences' function returns the list of all subsequences of the argument.------ >>> subsequences "abc"--- ["","a","b","ab","c","ac","bc","abc"]-subsequences            :: [a] -> [[a]]-subsequences xs         =  [] : nonEmptySubsequences xs---- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument,---   except for the empty list.------ >>> nonEmptySubsequences "abc"--- ["a","b","ab","c","ac","bc","abc"]-nonEmptySubsequences         :: [a] -> [[a]]-nonEmptySubsequences []      =  []-nonEmptySubsequences (x:xs)  =  [x] : foldr f [] (nonEmptySubsequences xs)-  where f ys r = ys : (x : ys) : r----- | The 'permutations' function returns the list of all permutations of the argument.------ >>> permutations "abc"--- ["abc","bac","cba","bca","cab","acb"]-permutations            :: [a] -> [[a]]-permutations xs0        =  xs0 : perms xs0 []-  where-    perms []     _  = []-    perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)-      where interleave    xs     r = let (_,zs) = interleave' id xs r in zs-            interleave' _ []     r = (ts, r)-            interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r-                                     in  (y:us, f (t:y:us) : zs)------------------------------------------------------------------------------------ Quick Sort algorithm taken from HBC's QSort library.---- | The 'sort' function implements a stable sorting algorithm.--- It is a special case of 'sortBy', which allows the programmer to supply--- their own comparison function.------ Elements are arranged from lowest to highest, keeping duplicates in--- the order they appeared in the input.------ >>> sort [1,6,4,3,2,5]--- [1,2,3,4,5,6]-sort :: (Ord a) => [a] -> [a]---- | The 'sortBy' function is the non-overloaded version of 'sort'.------ >>> sortBy (\(a,_) (b,_) -> compare a b) [(2, "world"), (4, "!"), (1, "Hello")]--- [(1,"Hello"),(2,"world"),(4,"!")]-sortBy :: (a -> a -> Ordering) -> [a] -> [a]--#if defined(USE_REPORT_PRELUDE)-sort = sortBy compare-sortBy cmp = foldr (insertBy cmp) []-#else--{--GHC's mergesort replaced by a better implementation, 24/12/2009.-This code originally contributed to the nhc12 compiler by Thomas Nordin-in 2002.  Rumoured to have been based on code by Lennart Augustsson, e.g.-    http://www.mail-archive.com/haskell@haskell.org/msg01822.html-and possibly to bear similarities to a 1982 paper by Richard O'Keefe:-"A smooth applicative merge sort".--Benchmarks show it to be often 2x the speed of the previous implementation.-Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/2143--}--sort = sortBy compare-sortBy cmp = mergeAll . sequences-  where-    sequences (a:b:xs)-      | a `cmp` b == GT = descending b [a]  xs-      | otherwise       = ascending  b (a:) xs-    sequences xs = [xs]--    descending a as (b:bs)-      | a `cmp` b == GT = descending b (a:as) bs-    descending a as bs  = (a:as): sequences bs--    ascending a as (b:bs)-      | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs-    ascending a as bs   = let !x = as [a]-                          in x : sequences bs--    mergeAll [x] = x-    mergeAll xs  = mergeAll (mergePairs xs)--    mergePairs (a:b:xs) = let !x = merge a b-                          in x : mergePairs xs-    mergePairs xs       = xs--    merge as@(a:as') bs@(b:bs')-      | a `cmp` b == GT = b:merge as  bs'-      | otherwise       = a:merge as' bs-    merge [] bs         = bs-    merge as []         = as--{--sortBy cmp l = mergesort cmp l-sort l = mergesort compare l--Quicksort replaced by mergesort, 14/5/2002.--From: Ian Lynagh <igloo@earth.li>--I am curious as to why the List.sort implementation in GHC is a-quicksort algorithm rather than an algorithm that guarantees n log n-time in the worst case? I have attached a mergesort implementation along-with a few scripts to time it's performance, the results of which are-shown below (* means it didn't finish successfully - in all cases this-was due to a stack overflow).--If I heap profile the random_list case with only 10000 then I see-random_list peaks at using about 2.5M of memory, whereas in the same-program using List.sort it uses only 100k.--Input style     Input length     Sort data     Sort alg    User time-stdin           10000            random_list   sort        2.82-stdin           10000            random_list   mergesort   2.96-stdin           10000            sorted        sort        31.37-stdin           10000            sorted        mergesort   1.90-stdin           10000            revsorted     sort        31.21-stdin           10000            revsorted     mergesort   1.88-stdin           100000           random_list   sort        *-stdin           100000           random_list   mergesort   *-stdin           100000           sorted        sort        *-stdin           100000           sorted        mergesort   *-stdin           100000           revsorted     sort        *-stdin           100000           revsorted     mergesort   *-func            10000            random_list   sort        0.31-func            10000            random_list   mergesort   0.91-func            10000            sorted        sort        19.09-func            10000            sorted        mergesort   0.15-func            10000            revsorted     sort        19.17-func            10000            revsorted     mergesort   0.16-func            100000           random_list   sort        3.85-func            100000           random_list   mergesort   *-func            100000           sorted        sort        5831.47-func            100000           sorted        mergesort   2.23-func            100000           revsorted     sort        5872.34-func            100000           revsorted     mergesort   2.24--mergesort :: (a -> a -> Ordering) -> [a] -> [a]-mergesort cmp = mergesort' cmp . map wrap--mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]-mergesort' _   [] = []-mergesort' _   [xs] = xs-mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)--merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]-merge_pairs _   [] = []-merge_pairs _   [xs] = [xs]-merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss--merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-merge _   [] ys = ys-merge _   xs [] = xs-merge cmp (x:xs) (y:ys)- = case x `cmp` y of-        GT -> y : merge cmp (x:xs)   ys-        _  -> x : merge cmp    xs (y:ys)--wrap :: a -> [a]-wrap x = [x]----OLDER: qsort version---- qsort is stable and does not concatenate.-qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-qsort _   []     r = r-qsort _   [x]    r = x:r-qsort cmp (x:xs) r = qpart cmp x xs [] [] r---- qpart partitions and sorts the sublists-qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]-qpart cmp x [] rlt rge r =-    -- rlt and rge are in reverse order and must be sorted with an-    -- anti-stable sorting-    rqsort cmp rlt (x:rqsort cmp rge r)-qpart cmp x (y:ys) rlt rge r =-    case cmp x y of-        GT -> qpart cmp x ys (y:rlt) rge r-        _  -> qpart cmp x ys rlt (y:rge) r---- rqsort is as qsort but anti-stable, i.e. reverses equal elements-rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-rqsort _   []     r = r-rqsort _   [x]    r = x:r-rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r--rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]-rqpart cmp x [] rle rgt r =-    qsort cmp rle (x:qsort cmp rgt r)-rqpart cmp x (y:ys) rle rgt r =-    case cmp y x of-        GT -> rqpart cmp x ys rle (y:rgt) r-        _  -> rqpart cmp x ys (y:rle) rgt r--}--#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--- 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.------ Elements are arranged from lowest to highest, keeping duplicates in--- the order they appeared in the input.------ >>> sortOn fst [(2, "world"), (4, "!"), (1, "Hello")]--- [(1,"Hello"),(2,"world"),(4,"!")]------ @since 4.8.0.0-sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f =-  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))---- | Produce singleton list.------ >>> singleton True--- [True]------ @since 4.15.0.0----singleton :: a -> [a]-singleton x = [x]---- | The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr'--- reduces a list to a summary value, 'unfoldr' builds a list from--- a seed value.  The function takes the element and returns 'Nothing'--- if it is done producing the list or returns 'Just' @(a,b)@, in which--- case, @a@ is a prepended to the list and @b@ is used as the next--- element in a recursive call.  For example,------ > iterate f == unfoldr (\x -> Just (x, f x))------ In some cases, 'unfoldr' can undo a 'foldr' operation:------ > unfoldr f' (foldr f z xs) == xs------ if the following holds:------ > f' (f x y) = Just (x,y)--- > f' z       = Nothing------ A simple use of unfoldr:------ >>> unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10--- [10,9,8,7,6,5,4,3,2,1]------- Note [INLINE unfoldr]--- We treat unfoldr a little differently from some other forms for list fusion--- for two reasons:------ 1. We don't want to use a rule to rewrite a basic form to a fusible--- form because this would inline before constant floating. As Simon Peyton---- Jones and others have pointed out, this could reduce sharing in some cases--- where sharing is beneficial. Thus we simply INLINE it, which is, for--- example, how enumFromTo::Int becomes eftInt. Unfortunately, we don't seem--- to get enough of an inlining discount to get a version of eftInt based on--- unfoldr to inline as readily as the usual one. We know that all the Maybe--- nonsense will go away, but the compiler does not.------ 2. The benefit of inlining unfoldr is likely to be huge in many common cases,--- even apart from list fusion. In particular, inlining unfoldr often--- allows GHC to erase all the Maybes. This appears to be critical if unfoldr--- is to be used in high-performance code. A small increase in code size--- in the relatively rare cases when this does not happen looks like a very--- small price to pay.------ Doing a back-and-forth dance doesn't seem to accomplish anything if the--- final form has to be inlined in any case.--unfoldr :: (b -> Maybe (a, b)) -> b -> [a]--{-# INLINE unfoldr #-} -- See Note [INLINE unfoldr]-unfoldr f b0 = build (\c n ->-  let go b = case f b of-               Just (a, new_b) -> a `c` go new_b-               Nothing         -> n-  in go b0)---- -------------------------------------------------------------------------------- Functions on strings---- | '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,--- so s' keeps a reference to the first line via the pair and we have--- a space leak (cf. #4334).--- So we need to make GHC see the selector thunks with a trick.-lines s                 =  cons (case break (== '\n') s of-                                    (l, s') -> (l, case s' of-                                                    []      -> []-                                                    _:s''   -> lines s''))-  where-    cons ~(h, t)        =  h : t---- | 'unlines' is an inverse operation to 'lines'.--- It joins lines, after appending a terminating newline to each.------ >>> unlines ["Hello", "World", "!"]--- "Hello\nWorld\n!\n"-unlines                 :: [String] -> String-#if defined(USE_REPORT_PRELUDE)-unlines                 =  concatMap (++ "\n")-#else--- HBC version (stolen)--- here's a more efficient version-unlines [] = []-unlines (l:ls) = l ++ '\n' : unlines ls-#endif---- | 'words' breaks a string up into a list of words, which were delimited--- by white space.------ >>> words "Lorem ipsum\ndolor"--- ["Lorem","ipsum","dolor"]-words                   :: String -> [String]-{-# NOINLINE [1] words #-}-words s                 =  case dropWhile {-partain:Char.-}isSpace s of-                                "" -> []-                                s' -> w : words s''-                                      where (w, s'') =-                                             break {-partain:Char.-}isSpace s'--{-# RULES-"words" [~1] forall s . words s = build (\c n -> wordsFB c n s)-"wordsList" [1] wordsFB (:) [] = words- #-}-wordsFB :: ([Char] -> b -> b) -> b -> String -> b-{-# INLINE [0] wordsFB #-} -- See Note [Inline FB functions] in GHC.List-wordsFB c n = go-  where-    go s = case dropWhile isSpace s of-             "" -> n-             s' -> w `c` go s''-                   where (w, s'') = break isSpace s'---- | 'unwords' is an inverse operation to 'words'.--- It joins words with separating spaces.------ >>> unwords ["Lorem", "ipsum", "dolor"]--- "Lorem ipsum dolor"-unwords                 :: [String] -> String-#if defined(USE_REPORT_PRELUDE)-unwords []              =  ""-unwords ws              =  foldr1 (\w s -> w ++ ' ':s) ws-#else--- Here's a lazier version that can get the last element of a--- _|_-terminated list.-{-# NOINLINE [1] unwords #-}-unwords []              =  ""-unwords (w:ws)          = w ++ go ws-  where-    go []     = ""-    go (v:vs) = ' ' : (v ++ go vs)---- In general, the foldr-based version is probably slightly worse--- than the HBC version, because it adds an extra space and then takes--- it back off again. But when it fuses, it reduces allocation. How much--- depends entirely on the average word length--it's most effective when--- the words are on the short side.-{-# RULES-"unwords" [~1] forall ws .-   unwords ws = tailUnwords (foldr unwordsFB "" ws)-"unwordsList" [1] forall ws .-   tailUnwords (foldr unwordsFB "" ws) = unwords ws- #-}--{-# INLINE [0] tailUnwords #-}-tailUnwords           :: String -> String-tailUnwords []        = []-tailUnwords (_:xs)    = xs--{-# INLINE [0] unwordsFB #-}-unwordsFB               :: String -> String -> String-unwordsFB w r           = ' ' : w ++ r-#endif--{- A "SnocBuilder" is a version of Chris Okasaki's banker's queue that supports-toListSB instead of uncons. In single-threaded use, its performance-characteristics are similar to John Hughes's functional difference lists, but-likely somewhat worse. In heavily persistent settings, however, it does much-better, because it takes advantage of sharing. The banker's queue guarantees-(amortized) O(1) snoc and O(1) uncons, meaning that we can think of toListSB as-an O(1) conversion to a list-like structure a constant factor slower than-normal lists--we pay the O(n) cost incrementally as we consume the list. Using-functional difference lists, on the other hand, we would have to pay the whole-cost up front for each output list. -}--{- We store a front list, a rear list, and the length of the queue.  Because we-only snoc onto the queue and never uncons, we know it's time to rotate when the-length of the queue plus 1 is a power of 2. Note that we rely on the value of-the length field only for performance.  In the unlikely event of overflow, the-performance will suffer but the semantics will remain correct.  -}--data SnocBuilder a = SnocBuilder {-# UNPACK #-} !Word [a] [a]--{- Smart constructor that rotates the builder when lp is one minus a power of-2. Does not rotate very small builders because doing so is not worth the-trouble. The lp < 255 test goes first because the power-of-2 test gives awful-branch prediction for very small n (there are 5 powers of 2 between 1 and-16). Putting the well-predicted lp < 255 test first avoids branching on the-power-of-2 test until powers of 2 have become sufficiently rare to be predicted-well. -}--{-# INLINE sb #-}-sb :: Word -> [a] -> [a] -> SnocBuilder a-sb lp f r-  | lp < 255 || (lp .&. (lp + 1)) /= 0 = SnocBuilder lp f r-  | otherwise                          = SnocBuilder lp (f ++ reverse r) []---- The empty builder--emptySB :: SnocBuilder a-emptySB = SnocBuilder 0 [] []---- Add an element to the end of a queue.--snocSB :: SnocBuilder a -> a -> SnocBuilder a-snocSB (SnocBuilder lp f r) x = sb (lp + 1) f (x:r)---- Convert a builder to a list--toListSB :: SnocBuilder a -> [a]-toListSB (SnocBuilder _ f r) = f ++ reverse r
− Data/Ord.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Ord--- Copyright   :  (c) The University of Glasgow 2005--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ Orderings-----------------------------------------------------------------------------------module Data.Ord (-   Ord(..),-   Ordering(..),-   Down(..),-   comparing,-   clamp,- ) where--import Data.Bits (Bits, FiniteBits)-import Foreign.Storable (Storable)-import GHC.Ix (Ix)-import GHC.Base-import GHC.Enum (Bounded(..))-import GHC.Float (Floating, RealFloat)-import GHC.Num-import GHC.Read-import GHC.Real (Fractional, Real, RealFrac)-import GHC.Show---- $setup--- >>> import Prelude---- |--- > comparing p x y = compare (p x) (p y)------ Useful combinator for use in conjunction with the @xxxBy@ family--- of functions from "Data.List", for example:------ >   ... sortBy (comparing fst) ...-comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering-comparing p x y = compare (p x) (p y)---- |--- > clamp (low, high) a = min high (max a low)------ Function for ensursing the value @a@ is within the inclusive bounds given by--- @low@ and @high@. If it is, @a@ is returned unchanged. The result--- is otherwise @low@ if @a <= low@, or @high@ if @high <= a@.------ When clamp is used at Double and Float, it has NaN propagating semantics in--- its second argument. That is, @clamp (l,h) NaN = NaN@, but @clamp (NaN, NaN)--- x = x@.------ >>> clamp (0, 10) 2--- 2------ >>> clamp ('a', 'm') 'x'--- 'm'-clamp :: (Ord a) => (a, a) -> a -> a-clamp (low, high) a = min high (max a low)---- | The 'Down' type allows you to reverse sort order conveniently.  A value of type--- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@).------ If @a@ has an @'Ord'@ instance associated with it then comparing two--- values thus wrapped will give you the opposite of their normal sort order.--- This is particularly useful when sorting in generalised list comprehensions,--- as in: @then sortWith by 'Down' x@.------ >>> compare True False--- GT------ >>> compare (Down True) (Down False)--- LT------ If @a@ has a @'Bounded'@ instance then the wrapped instance also respects--- the reversed ordering by exchanging the values of @'minBound'@ and--- @'maxBound'@.------ >>> minBound :: Int--- -9223372036854775808------ >>> minBound :: Down Int--- Down 9223372036854775807------ All other instances of @'Down' a@ behave as they do for @a@.------ @since 4.6.0.0-newtype Down a = Down-    { getDown :: a -- ^ @since 4.14.0.0-    }-    deriving-      ( Eq        -- ^ @since 4.6.0.0-      , Num       -- ^ @since 4.11.0.0-      , Semigroup -- ^ @since 4.11.0.0-      , Monoid    -- ^ @since 4.11.0.0-      , Bits       -- ^ @since 4.14.0.0-      , FiniteBits -- ^ @since 4.14.0.0-      , Floating   -- ^ @since 4.14.0.0-      , Fractional -- ^ @since 4.14.0.0-      , Ix         -- ^ @since 4.14.0.0-      , Real       -- ^ @since 4.14.0.0-      , RealFrac   -- ^ @since 4.14.0.0-      , RealFloat  -- ^ @since 4.14.0.0-      , Storable   -- ^ @since 4.14.0.0-      )---- | This instance would be equivalent to the derived instances of the--- 'Down' newtype if the 'getDown' field were removed------ @since 4.7.0.0-instance (Read a) => Read (Down a) where-    readsPrec d = readParen (d > 10) $ \ r ->-        [(Down x,t) | ("Down",s) <- lex r, (x,t) <- readsPrec 11 s]---- | This instance would be equivalent to the derived instances of the--- 'Down' newtype if the 'getDown' field were removed------ @since 4.7.0.0-instance (Show a) => Show (Down a) where-    showsPrec d (Down x) = showParen (d > 10) $-        showString "Down " . showsPrec 11 x---- | @since 4.6.0.0-instance Ord a => Ord (Down a) where-    compare (Down x) (Down y) = y `compare` x---- | Swaps @'minBound'@ and @'maxBound'@ of the underlying type.------ @since 4.14.0.0-instance Bounded a => Bounded (Down a) where-    minBound = Down maxBound-    maxBound = Down minBound---- | @since 4.11.0.0-instance Functor Down where-    fmap = coerce---- | @since 4.11.0.0-instance Applicative Down where-    pure = Down-    (<*>) = coerce---- | @since 4.11.0.0-instance Monad Down where-    Down a >>= k = k a
− Data/Proxy.hs 
@@ -1,158 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Proxy--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Definition of a Proxy type (poly-kinded in GHC)------ @since 4.7.0.0--------------------------------------------------------------------------------module Data.Proxy-  (-        Proxy(..), asProxyTypeOf-      , KProxy(..)-  ) where--import GHC.Base-import GHC.Show-import GHC.Read-import GHC.Enum-import GHC.Arr---- $setup--- >>> import Data.Void--- >>> import Prelude---- | 'Proxy' is a type that holds no data, but has a phantom parameter of--- arbitrary type (or even kind). Its use is to provide type information, even--- though there is no value available of that type (or it may be too costly to--- create one).------ Historically, @'Proxy' :: 'Proxy' a@ is a safer alternative to the--- @'undefined' :: a@ idiom.------ >>> Proxy :: Proxy (Void, Int -> Int)--- Proxy------ Proxy can even hold types of higher kinds,------ >>> Proxy :: Proxy Either--- Proxy------ >>> Proxy :: Proxy Functor--- Proxy------ >>> Proxy :: Proxy complicatedStructure--- Proxy-data Proxy t = Proxy deriving ( Bounded -- ^ @since 4.7.0.0-                              , Read    -- ^ @since 4.7.0.0-                              )---- | A concrete, promotable proxy type, for use at the kind level.--- There are no instances for this because it is intended at the kind level only-data KProxy (t :: Type) = KProxy---- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t)--- interchangeably, so all of these instances are hand-written to be--- lazy in Proxy arguments.---- | @since 4.7.0.0-instance Eq (Proxy s) where-  _ == _ = True---- | @since 4.7.0.0-instance Ord (Proxy s) where-  compare _ _ = EQ---- | @since 4.7.0.0-instance Show (Proxy s) where-  showsPrec _ _ = showString "Proxy"---- | @since 4.7.0.0-instance Enum (Proxy s) where-    succ _               = errorWithoutStackTrace "Proxy.succ"-    pred _               = errorWithoutStackTrace "Proxy.pred"-    fromEnum _           = 0-    toEnum 0             = Proxy-    toEnum _             = errorWithoutStackTrace "Proxy.toEnum: 0 expected"-    enumFrom _           = [Proxy]-    enumFromThen _ _     = [Proxy]-    enumFromThenTo _ _ _ = [Proxy]-    enumFromTo _ _       = [Proxy]---- | @since 4.7.0.0-instance Ix (Proxy s) where-    range _           = [Proxy]-    index _ _         = 0-    inRange _ _       = True-    rangeSize _       = 1-    unsafeIndex _ _   = 0-    unsafeRangeSize _ = 1---- | @since 4.9.0.0-instance Semigroup (Proxy s) where-    _ <> _ = Proxy-    sconcat _ = Proxy-    stimes _ _ = Proxy---- | @since 4.7.0.0-instance Monoid (Proxy s) where-    mempty = Proxy-    mconcat _ = Proxy---- | @since 4.7.0.0-instance Functor Proxy where-    fmap _ _ = Proxy-    {-# INLINE fmap #-}---- | @since 4.7.0.0-instance Applicative Proxy where-    pure _ = Proxy-    {-# INLINE pure #-}-    _ <*> _ = Proxy-    {-# INLINE (<*>) #-}---- | @since 4.9.0.0-instance Alternative Proxy where-    empty = Proxy-    {-# INLINE empty #-}-    _ <|> _ = Proxy-    {-# INLINE (<|>) #-}---- | @since 4.7.0.0-instance Monad Proxy where-    _ >>= _ = Proxy-    {-# INLINE (>>=) #-}---- | @since 4.9.0.0-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--- argument (which is usually overloaded) to have the same type as the tag--- of the second.------ >>> import Data.Word--- >>> :type asProxyTypeOf 123 (Proxy :: Proxy Word8)--- asProxyTypeOf 123 (Proxy :: Proxy Word8) :: Word8------ Note the lower-case @proxy@ in the definition. This allows any type--- constructor with just one argument to be passed to the function, for example--- we could also write------ >>> import Data.Word--- >>> :type asProxyTypeOf 123 (Just (undefined :: Word8))--- asProxyTypeOf 123 (Just (undefined :: Word8)) :: Word8-asProxyTypeOf :: a -> proxy a -> a-asProxyTypeOf = const-{-# INLINE asProxyTypeOf #-}-
− Data/Ratio.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Ratio--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ Standard functions on rational numbers-----------------------------------------------------------------------------------module Data.Ratio-    ( Ratio-    , Rational-    , (%)-    , numerator-    , denominator-    , approxRational--  ) where--import GHC.Real         -- The basic defns for Ratio---- -------------------------------------------------------------------------------- approxRational---- | 'approxRational', applied to two real fractional numbers @x@ and @epsilon@,--- returns the simplest rational number within @epsilon@ of @x@.--- A rational number @y@ is said to be /simpler/ than another @y'@ if------ * @'abs' ('numerator' y) <= 'abs' ('numerator' y')@, and------ * @'denominator' y <= 'denominator' y'@.------ Any real interval contains a unique simplest rational;--- in particular, note that @0\/1@ is the simplest rational of all.---- Implementation details: Here, for simplicity, we assume a closed rational--- interval.  If such an interval includes at least one whole number, then--- the simplest rational is the absolutely least whole number.  Otherwise,--- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d--- and abs r' < d', and the simplest rational is q%1 + the reciprocal of--- the simplest rational between d'%r' and d%r.--approxRational :: (RealFrac a) => a -> a -> Rational-approxRational rat eps =-    -- We convert rat and eps to rational *before* subtracting/adding since-    -- otherwise we may overflow. This was the cause of #14425.-    simplest (toRational rat - toRational eps) (toRational rat + toRational eps)-  where-    simplest x y-      | y < x      =  simplest y x-      | x == y     =  xr-      | x > 0      =  simplest' n d n' d'-      | y < 0      =  - simplest' (-n') d' (-n) d-      | otherwise  =  0 :% 1-      where xr  = toRational x-            n   = numerator xr-            d   = denominator xr-            nd' = toRational y-            n'  = numerator nd'-            d'  = denominator nd'--    simplest' n d n' d'       -- assumes 0 < n%d < n'%d'-      | r == 0     =  q :% 1-      | q /= q'    =  (q+1) :% 1-      | otherwise  =  (q*n''+d'') :% n''-      where (q,r)      =  quotRem n d-            (q',r')    =  quotRem n' d'-            nd''       =  simplest' d' r' d r-            n''        =  numerator nd''-            d''        =  denominator nd''-
− Data/STRef.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.STRef--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Control.Monad.ST)------ Mutable references in the (strict) ST monad.-----------------------------------------------------------------------------------module Data.STRef (-        -- * STRefs-        STRef,          -- abstract-        newSTRef,-        readSTRef,-        writeSTRef,-        modifySTRef,-        modifySTRef'- ) where--import GHC.ST-import GHC.STRef---- $setup--- >>> import Prelude--- >>> import Control.Monad.ST---- | Mutate the contents of an 'STRef'.------ >>> :{--- runST (do---     ref <- newSTRef ""---     modifySTRef ref (const "world")---     modifySTRef ref (++ "!")---     modifySTRef ref ("Hello, " ++)---     readSTRef ref )--- :}--- "Hello, world!"------ Be warned that 'modifySTRef' does not apply the function strictly.  This--- means if the program calls 'modifySTRef' many times, but seldom uses the--- value, thunks will pile up in memory resulting in a space leak.  This is a--- common mistake made when using an 'STRef' as a counter.  For example, the--- following will leak memory and may produce a stack overflow:------ >>> import Control.Monad (replicateM_)--- >>> :{--- print (runST (do---     ref <- newSTRef 0---     replicateM_ 1000 $ modifySTRef ref (+1)---     readSTRef ref ))--- :}--- 1000------ To avoid this problem, use 'modifySTRef'' instead.-modifySTRef :: STRef s a -> (a -> a) -> ST s ()-modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref---- | Strict version of 'modifySTRef'------ @since 4.6.0.0-modifySTRef' :: STRef s a -> (a -> a) -> ST s ()-modifySTRef' ref f = do-    x <- readSTRef ref-    let x' = f x-    x' `seq` writeSTRef ref x'
− Data/STRef/Lazy.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  Data.STRef.Lazy--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Control.Monad.ST.Lazy)------ Mutable references in the lazy ST monad.-----------------------------------------------------------------------------------module Data.STRef.Lazy (-        -- * STRefs-        ST.STRef,       -- abstract-        newSTRef,-        readSTRef,-        writeSTRef,-        modifySTRef- ) where--import Control.Monad.ST.Lazy-import qualified Data.STRef as ST--newSTRef    :: a -> ST s (ST.STRef s a)-readSTRef   :: ST.STRef s a -> ST s a-writeSTRef  :: ST.STRef s a -> a -> ST s ()-modifySTRef :: ST.STRef s a -> (a -> a) -> ST s ()--newSTRef        = strictToLazyST . ST.newSTRef-readSTRef       = strictToLazyST . ST.readSTRef-writeSTRef  r a = strictToLazyST (ST.writeSTRef r a)-modifySTRef r f = strictToLazyST (ST.modifySTRef r f)-
− Data/STRef/Strict.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  Data.STRef.Strict--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (uses Control.Monad.ST.Strict)------ Mutable references in the (strict) ST monad (re-export of "Data.STRef")-----------------------------------------------------------------------------------module Data.STRef.Strict (-        module Data.STRef-  ) where--import Data.STRef-
− Data/Semigroup.hs 
@@ -1,509 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE PolyKinds                  #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE Trustworthy                #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Semigroup--- Copyright   :  (C) 2011-2015 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ A type @a@ is a 'Semigroup' if it provides an associative function ('<>')--- that lets you combine any two values of type @a@ into one. Where being--- associative means that the following must always hold:------ prop> (a <> b) <> c == a <> (b <> c)------ ==== __Examples__------ The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller--- number:--- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int--- Min {getMin = 1}------ If we need to combine multiple values we can use the 'sconcat' function--- to do so. We need to ensure however that we have at least one value to--- operate on, since otherwise our result would be undefined. It is for this--- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that--- can never be empty:------ >>> (1 :| [])--- 1 :| []               -- equivalent to [1] but guaranteed to be non-empty.------ >>> (1 :| [2, 3, 4])--- 1 :| [2,3,4]          -- equivalent to [1,2,3,4] but guaranteed to be non-empty.------ Equipped with this guaranteed to be non-empty data structure, we can combine--- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min'--- and 'Max' instances of 'Int' which pick the smallest, or largest number--- respectively:------ >>> sconcat (1 :| [2, 3, 4]) :: Min Int--- Min {getMin = 1}--- >>> sconcat (1 :| [2, 3, 4]) :: Max Int--- Max {getMax = 4}------ String concatenation is another example of a 'Semigroup' instance:------ >>> "foo" <> "bar"--- "foobar"------ A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid'--- requires the presence of a neutral element ('mempty') in addition to the associative--- operator. The requirement for a neutral element prevents many types from being a full Monoid,--- like "Data.List.NonEmpty.NonEmpty".------ Note that 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-  , Dual(..)-  , Endo(..)-  , All(..)-  , Any(..)-  , Sum(..)-  , Product(..)-  -- * Difference lists of a semigroup-  , diff-  , cycle1-  -- * ArgMin, ArgMax-  , Arg(..)-  , ArgMin-  , ArgMax-  ) where--import           Prelude             hiding (foldr1)--import GHC.Base (Semigroup(..))--import           Data.Semigroup.Internal--import           Control.Applicative-import           Control.Monad.Fix-import           Data.Bifoldable-import           Data.Bifunctor-import           Data.Bitraversable-import           Data.Coerce-import           Data.Data-import           GHC.Generics---- $setup--- >>> import Prelude--- >>> import Data.List.NonEmpty (NonEmpty (..))---- | 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'---- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.------ === __Example:__--- >>> let hello = diff "Hello, "--- >>> appEndo hello "World!"--- "Hello, World!"--- >>> appEndo (hello <> mempty) "World!"--- "Hello, World!"--- >>> appEndo (mempty <> hello) "World!"--- "Hello, World!"--- >>> let world = diff "World"--- >>> let excl = diff "!"--- >>> appEndo (hello <> (world <> excl)) mempty--- "Hello, World!"--- >>> appEndo ((hello <> world) <> excl) mempty--- "Hello, World!"-diff :: Semigroup m => m -> Endo m-diff = Endo . (<>)--newtype Min a = Min { getMin :: a }-  deriving ( Bounded  -- ^ @since 4.9.0.0-           , Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Read     -- ^ @since 4.9.0.0-           , Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Enum a => Enum (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----- | @since 4.9.0.0-instance Ord a => Semigroup (Min a) where-  (<>) = coerce (min :: a -> a -> a)-  stimes = stimesIdempotent---- | @since 4.9.0.0-instance (Ord a, Bounded a) => Monoid (Min a) where-  mempty = maxBound---- | @since 4.9.0.0-instance Functor Min where-  fmap f (Min x) = Min (f x)---- | @since 4.9.0.0-instance Foldable Min where-  foldMap f (Min a) = f a---- | @since 4.9.0.0-instance Traversable Min where-  traverse f (Min a) = Min <$> f a---- | @since 4.9.0.0-instance Applicative Min where-  pure = Min-  a <* _ = a-  _ *> a = a-  (<*>) = coerce-  liftA2 = coerce---- | @since 4.9.0.0-instance Monad Min where-  (>>) = (*>)-  Min a >>= f = f a---- | @since 4.9.0.0-instance MonadFix Min where-  mfix f = fix (f . getMin)---- | @since 4.9.0.0-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 ( Bounded  -- ^ @since 4.9.0.0-           , Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Read     -- ^ @since 4.9.0.0-           , Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Enum a => Enum (Max a) where-  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---- | @since 4.9.0.0-instance Ord a => Semigroup (Max a) where-  (<>) = coerce (max :: a -> a -> a)-  stimes = stimesIdempotent---- | @since 4.9.0.0-instance (Ord a, Bounded a) => Monoid (Max a) where-  mempty = minBound---- | @since 4.9.0.0-instance Functor Max where-  fmap f (Max x) = Max (f x)---- | @since 4.9.0.0-instance Foldable Max where-  foldMap f (Max a) = f a---- | @since 4.9.0.0-instance Traversable Max where-  traverse f (Max a) = Max <$> f a---- | @since 4.9.0.0-instance Applicative Max where-  pure = Max-  a <* _ = a-  _ *> a = a-  (<*>) = coerce-  liftA2 = coerce---- | @since 4.9.0.0-instance Monad Max where-  (>>) = (*>)-  Max a >>= f = f a---- | @since 4.9.0.0-instance MonadFix Max where-  mfix f = fix (f . getMax)---- | @since 4.9.0.0-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.------ >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ]--- Arg 0 0-data Arg a b = Arg-  a-  -- ^ The argument used for comparisons in 'Eq' and 'Ord'.-  b-  -- ^ The "value" exposed via the 'Functor', 'Foldable' etc. instances.-  deriving-  ( Show     -- ^ @since 4.9.0.0-  , Read     -- ^ @since 4.9.0.0-  , Data     -- ^ @since 4.9.0.0-  , Generic  -- ^ @since 4.9.0.0-  , Generic1 -- ^ @since 4.9.0.0-  )---- |--- >>> Min (Arg 0 ()) <> Min (Arg 1 ())--- Min {getMin = Arg 0 ()}-type ArgMin a b = Min (Arg a b)---- |--- >>> Max (Arg 0 ()) <> Max (Arg 1 ())--- Max {getMax = Arg 1 ()}-type ArgMax a b = Max (Arg a b)---- | @since 4.9.0.0-instance Functor (Arg a) where-  fmap f (Arg x a) = Arg x (f a)---- | @since 4.9.0.0-instance Foldable (Arg a) where-  foldMap f (Arg _ a) = f a---- | @since 4.9.0.0-instance Traversable (Arg a) where-  traverse f (Arg x a) = Arg x <$> f a---- | @since 4.9.0.0-instance Eq a => Eq (Arg a b) where-  Arg a _ == Arg b _ = a == b---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance Bifunctor Arg where-  bimap f g (Arg a b) = Arg (f a) (g b)---- | @since 4.10.0.0-instance Bifoldable Arg where-  bifoldMap f g (Arg a b) = f a <> g b---- | @since 4.10.0.0-instance Bitraversable Arg where-  bitraverse f g (Arg a b) = Arg <$> f a <*> g b--newtype First a = First { getFirst :: a }-  deriving ( Bounded  -- ^ @since 4.9.0.0-           , Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Read     -- ^ @since 4.9.0.0-           , Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Enum a => Enum (First a) where-  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---- | @since 4.9.0.0-instance Semigroup (First a) where-  a <> _ = a-  stimes = stimesIdempotent---- | @since 4.9.0.0-instance Functor First where-  fmap f (First x) = First (f x)---- | @since 4.9.0.0-instance Foldable First where-  foldMap f (First a) = f a---- | @since 4.9.0.0-instance Traversable First where-  traverse f (First a) = First <$> f a---- | @since 4.9.0.0-instance Applicative First where-  pure x = First x-  a <* _ = a-  _ *> a = a-  (<*>) = coerce-  liftA2 = coerce---- | @since 4.9.0.0-instance Monad First where-  (>>) = (*>)-  First a >>= f = f a---- | @since 4.9.0.0-instance MonadFix First where-  mfix f = fix (f . getFirst)--newtype Last a = Last { getLast :: a }-  deriving ( Bounded  -- ^ @since 4.9.0.0-           , Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Read     -- ^ @since 4.9.0.0-           , Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Enum a => Enum (Last a) where-  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---- | @since 4.9.0.0-instance Semigroup (Last a) where-  _ <> b = b-  stimes = stimesIdempotent---- | @since 4.9.0.0-instance Functor Last where-  fmap f (Last x) = Last (f x)-  a <$ _ = Last a---- | @since 4.9.0.0-instance Foldable Last where-  foldMap f (Last a) = f a---- | @since 4.9.0.0-instance Traversable Last where-  traverse f (Last a) = Last <$> f a---- | @since 4.9.0.0-instance Applicative Last where-  pure = Last-  a <* _ = a-  _ *> a = a-  (<*>) = coerce-  liftA2 = coerce---- | @since 4.9.0.0-instance Monad Last where-  (>>) = (*>)-  Last a >>= f = f a---- | @since 4.9.0.0-instance MonadFix Last where-  mfix f = fix (f . getLast)---- | Provide a Semigroup for an arbitrary Monoid.------ __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of--- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future.-newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }-  deriving ( Bounded  -- ^ @since 4.9.0.0-           , Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Read     -- ^ @since 4.9.0.0-           , Data     -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Monoid m => Semigroup (WrappedMonoid m) where-  (<>) = coerce (mappend :: m -> m -> m)---- | @since 4.9.0.0-instance Monoid m => Monoid (WrappedMonoid m) where-  mempty = WrapMonoid mempty---- | @since 4.9.0.0-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))
− Data/Semigroup/Internal.hs 
@@ -1,318 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Auxiliary definitions for 'Semigroup'------ This module provides some @newtype@ wrappers and helpers which are--- reexported from the "Data.Semigroup" module or imported directly--- by some other modules.------ This module also provides internal definitions related to the--- 'Semigroup' class some.------ This module exists mostly to simplify or workaround import-graph--- issues; there is also a .hs-boot file to allow "GHC.Base" and other--- modules to import method default implementations for 'stimes'------ @since 4.11.0.0-module Data.Semigroup.Internal where--import GHC.Base hiding (Any)-import GHC.Enum-import GHC.Num-import GHC.Read-import GHC.Show-import GHC.Generics-import GHC.Real---- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.------ When @x <> x = x@, this definition should be preferred, because it--- works in \(\mathcal{O}(1)\) rather than \(\mathcal{O}(\log n)\).-stimesIdempotent :: Integral b => b -> a -> a-stimesIdempotent n x-  | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"-  | otherwise = x---- | 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 \(\mathcal{O}(1)\) rather than \(\mathcal{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 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) (y `quot` 2) x               -- See Note [Half of y - 1]-      g x y z-        | even y = g (x `mappend` x) (y `quot` 2) z-        | y == 1 = x `mappend` z-        | otherwise = g (x `mappend` x) (y `quot` 2) (x `mappend` z) -- See Note [Half of y - 1]---- this is used by the class definitionin GHC.Base;--- it lives here to avoid cycles-stimesDefault :: (Integral b, Semigroup a) => b -> a -> a-stimesDefault 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) (y `quot` 2) x        -- See Note [Half of y - 1]-    g x y z-      | even y = g (x <> x) (y `quot` 2) z-      | y == 1 = x <> z-      | otherwise = g (x <> x) (y `quot` 2) (x <> z) -- See Note [Half of y - 1]--{- Note [Half of y - 1]-   ~~~~~~~~~~~~~~~~~~~~~-   Since y is guaranteed to be odd and positive here,-   half of y - 1 can be computed as y `quot` 2, optimising subtraction away.--}--stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a-stimesMaybe _ Nothing = Nothing-stimesMaybe n (Just a) = case compare n 0 of-    LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"-    EQ -> Nothing-    GT -> Just (stimes n a)--stimesList  :: Integral b => b -> [a] -> [a]-stimesList n x-  | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"-  | otherwise = rep n-  where-    rep 0 = []-    rep i = x ++ rep (i - 1)---- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'.------ >>> getDual (mappend (Dual "Hello") (Dual "World"))--- "WorldHello"-newtype Dual a = Dual { getDual :: a }-        deriving ( Eq       -- ^ @since 2.01-                 , Ord      -- ^ @since 2.01-                 , Read     -- ^ @since 2.01-                 , Show     -- ^ @since 2.01-                 , Bounded  -- ^ @since 2.01-                 , Generic  -- ^ @since 4.7.0.0-                 , Generic1 -- ^ @since 4.7.0.0-                 )---- | @since 4.9.0.0-instance Semigroup a => Semigroup (Dual a) where-        Dual a <> Dual b = Dual (b <> a)-        stimes n (Dual a) = Dual (stimes n a)---- | @since 2.01-instance Monoid a => Monoid (Dual a) where-        mempty = Dual mempty---- | @since 4.8.0.0-instance Functor Dual where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Dual where-    pure     = Dual-    (<*>)    = coerce---- | @since 4.8.0.0-instance Monad Dual where-    m >>= k  = k (getDual m)---- | The monoid of endomorphisms under composition.------ >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!")--- >>> appEndo computation "Haskell"--- "Hello, Haskell!"-newtype Endo a = Endo { appEndo :: a -> a }-               deriving ( Generic -- ^ @since 4.7.0.0-                        )---- | @since 4.9.0.0-instance Semigroup (Endo a) where-        (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))-        stimes = stimesMonoid---- | @since 2.01-instance Monoid (Endo a) where-        mempty = Endo id---- | Boolean monoid under conjunction ('&&').------ >>> getAll (All True <> mempty <> All False)--- False------ >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8]))--- False-newtype All = All { getAll :: Bool }-        deriving ( Eq      -- ^ @since 2.01-                 , Ord     -- ^ @since 2.01-                 , Read    -- ^ @since 2.01-                 , Show    -- ^ @since 2.01-                 , Bounded -- ^ @since 2.01-                 , Generic -- ^ @since 4.7.0.0-                 )---- | @since 4.9.0.0-instance Semigroup All where-        (<>) = coerce (&&)-        stimes = stimesIdempotentMonoid---- | @since 2.01-instance Monoid All where-        mempty = All True---- | Boolean monoid under disjunction ('||').------ >>> getAny (Any True <> mempty <> Any False)--- True------ >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8]))--- True-newtype Any = Any { getAny :: Bool }-        deriving ( Eq      -- ^ @since 2.01-                 , Ord     -- ^ @since 2.01-                 , Read    -- ^ @since 2.01-                 , Show    -- ^ @since 2.01-                 , Bounded -- ^ @since 2.01-                 , Generic -- ^ @since 4.7.0.0-                 )---- | @since 4.9.0.0-instance Semigroup Any where-        (<>) = coerce (||)-        stimes = stimesIdempotentMonoid---- | @since 2.01-instance Monoid Any where-        mempty = Any False---- | Monoid under addition.------ >>> getSum (Sum 1 <> Sum 2 <> mempty)--- 3-newtype Sum a = Sum { getSum :: a }-        deriving ( Eq       -- ^ @since 2.01-                 , Ord      -- ^ @since 2.01-                 , Read     -- ^ @since 2.01-                 , Show     -- ^ @since 2.01-                 , Bounded  -- ^ @since 2.01-                 , Generic  -- ^ @since 4.7.0.0-                 , Generic1 -- ^ @since 4.7.0.0-                 , Num      -- ^ @since 4.7.0.0-                 )---- | @since 4.9.0.0-instance Num a => Semigroup (Sum a) where-        (<>) = coerce ((+) :: a -> a -> a)-        stimes n (Sum a) = Sum (fromIntegral n * a)---- | @since 2.01-instance Num a => Monoid (Sum a) where-        mempty = Sum 0---- | @since 4.8.0.0-instance Functor Sum where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Sum where-    pure     = Sum-    (<*>)    = coerce---- | @since 4.8.0.0-instance Monad Sum where-    m >>= k  = k (getSum m)---- | Monoid under multiplication.------ >>> getProduct (Product 3 <> Product 4 <> mempty)--- 12-newtype Product a = Product { getProduct :: a }-        deriving ( Eq       -- ^ @since 2.01-                 , Ord      -- ^ @since 2.01-                 , Read     -- ^ @since 2.01-                 , Show     -- ^ @since 2.01-                 , Bounded  -- ^ @since 2.01-                 , Generic  -- ^ @since 4.7.0.0-                 , Generic1 -- ^ @since 4.7.0.0-                 , Num      -- ^ @since 4.7.0.0-                 )---- | @since 4.9.0.0-instance Num a => Semigroup (Product a) where-        (<>) = coerce ((*) :: a -> a -> a)-        stimes n (Product a) = Product (a ^ n)----- | @since 2.01-instance Num a => Monoid (Product a) where-        mempty = Product 1---- | @since 4.8.0.0-instance Functor Product where-    fmap     = coerce---- | @since 4.8.0.0-instance Applicative Product where-    pure     = Product-    (<*>)    = coerce---- | @since 4.8.0.0-instance Monad Product where-    m >>= k  = k (getProduct m)----- | Monoid under '<|>'.------ >>> getAlt (Alt (Just 12) <> Alt (Just 24))--- Just 12------ >>> getAlt $ Alt Nothing <> Alt (Just 24)--- Just 24------ @since 4.8.0.0-newtype Alt f a = Alt {getAlt :: f a}-  deriving ( Generic     -- ^ @since 4.8.0.0-           , Generic1    -- ^ @since 4.8.0.0-           , Read        -- ^ @since 4.8.0.0-           , Show        -- ^ @since 4.8.0.0-           , Eq          -- ^ @since 4.8.0.0-           , Ord         -- ^ @since 4.8.0.0-           , Num         -- ^ @since 4.8.0.0-           , Enum        -- ^ @since 4.8.0.0-           , Monad       -- ^ @since 4.8.0.0-           , MonadPlus   -- ^ @since 4.8.0.0-           , Applicative -- ^ @since 4.8.0.0-           , Alternative -- ^ @since 4.8.0.0-           , Functor     -- ^ @since 4.8.0.0-           )---- | @since 4.9.0.0-instance Alternative f => Semigroup (Alt f a) where-    (<>) = coerce ((<|>) :: f a -> f a -> f a)-    stimes = stimesMonoid---- | @since 4.8.0.0-instance Alternative f => Monoid (Alt f a) where-    mempty = Alt empty
− Data/Semigroup/Internal.hs-boot 
@@ -1,13 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Semigroup.Internal where--import {-# SOURCE #-} GHC.Real (Integral)-import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe)-import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base--stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a--stimesDefault :: (Integral b, Semigroup a) => b -> a -> a-stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a-stimesList :: Integral b => b -> [a] -> [a]
− Data/String.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}---------------------------------------------------------------------------------- |--- Module      :  Data.String--- Copyright   :  (c) The University of Glasgow 2007--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ The @String@ type and associated operations.-----------------------------------------------------------------------------------module Data.String (-   String- , IsString(..)-- -- * Functions on strings- , lines- , words- , unlines- , unwords- ) where--import GHC.Base-import Data.Functor.Const (Const (Const))-import Data.Functor.Identity (Identity (Identity))-import Data.List (lines, words, unlines, unwords)---- | Class for string-like datastructures; used by the overloaded string---   extension (-XOverloadedStrings in GHC).-class IsString a where-    fromString :: String -> a--{- 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.--}---- | @(a ~ Char)@ context was introduced in @4.9.0.0@------ @since 2.01-instance (a ~ Char) => IsString [a] where-         -- See Note [IsString String]-    fromString xs = xs---- | @since 4.9.0.0-deriving instance IsString a => IsString (Const a (b :: k))---- | @since 4.9.0.0-deriving instance IsString a => IsString (Identity a)
− Data/Traversable.hs 
@@ -1,1529 +0,0 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Traversable--- 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------ Class of data structures that can be traversed from left to right,--- performing an action on each element.  Instances are expected to satisfy--- the listed [laws](#laws).--------------------------------------------------------------------------------module Data.Traversable (-    -- * The 'Traversable' class-    Traversable(..),-    -- * Utility functions-    for,-    forM,-    mapAccumL,-    mapAccumR,-    -- * General definitions for superclass methods-    fmapDefault,-    foldMapDefault,--    -- * Overview-    -- $overview--    -- ** The 'traverse' and 'mapM' methods-    -- $traverse--    -- *** Their 'Foldable', just the effects, analogues.-    -- $effectful--    -- *** Result multiplicity-    -- $multiplicity--    -- ** The 'sequenceA' and 'sequence' methods-    -- $sequence--    -- *** Care with default method implementations-    -- $seqdefault--    -- *** Monadic short circuits-    -- $seqshort--    -- ** Example binary tree instance-    -- $tree_instance--    -- *** Pre-order and post-order tree traversal-    -- $tree_order--    -- ** Making construction intuitive-    ---    -- $construction--    -- * Advanced traversals-    -- $advanced--    -- *** Coercion-    -- $coercion--    -- ** Identity: the 'fmapDefault' function-    -- $identity--    -- ** State: the 'mapAccumL', 'mapAccumR' functions-    -- $stateful--    -- ** Const: the 'foldMapDefault' function-    -- $phantom--    -- ** ZipList: transposing lists of lists-    -- $ziplist--    -- * Laws-    ---    -- $laws--    -- * See also-    -- $also-    ) where---- 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.Coerce-import Data.Either ( Either(..) )-import Data.Foldable-import Data.Functor-import Data.Functor.Identity ( Identity(..) )-import Data.Functor.Utils ( StateL(..), StateR(..) )-import Data.Monoid ( Dual(..), Sum(..), Product(..),-                     First(..), Last(..), Alt(..), Ap(..) )-import Data.Ord ( Down(..) )-import Data.Proxy ( Proxy(..) )--import GHC.Arr-import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), NonEmpty(..),-                  ($), (.), id, flip )-import GHC.Generics-import qualified GHC.List as List ( foldr )-import GHC.Tuple (Solo (..))---- $setup--- >>> import Prelude--- >>> import Data.Maybe (catMaybes, mapMaybe)--- >>> import Data.Either (rights)--- >>> import Data.Foldable (traverse_)---- XXX: Missing haddock feature.  Links to anchors in other modules--- don't have a sensible way to name the link within the module itself.--- Thus, the below "Data.Traversable#overview" works well when shown as--- @Data.Traversable@ from other modules, but in the home module it should--- be possible to specify alternative link text. :-(---- | Functors representing data structures that can be transformed to--- structures of the /same shape/ by performing an 'Applicative' (or,--- therefore, 'Monad') action on each element from left to right.------ A more detailed description of what /same shape/ means, the various methods,--- how traversals are constructed, and example advanced use-cases can be found--- in the __Overview__ section of "Data.Traversable#overview".------ For the class laws see the __Laws__ section of "Data.Traversable#laws".----class (Functor t, Foldable t) => Traversable t where-    {-# MINIMAL traverse | sequenceA #-}--    -- | Map each element of a structure to an action, evaluate these actions-    -- from left to right, and collect the results. For a version that ignores-    -- the results see 'Data.Foldable.traverse_'.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- In the first two examples we show each evaluated action mapping to the-    -- output structure.-    ---    -- >>> traverse Just [1,2,3,4]-    -- Just [1,2,3,4]-    ---    -- >>> traverse id [Right 1, Right 2, Right 3, Right 4]-    -- Right [1,2,3,4]-    ---    -- In the next examples, we show that 'Nothing' and 'Left' values short-    -- circuit the created structure.-    ---    -- >>> traverse (const Nothing) [1,2,3,4]-    -- Nothing-    ---    -- >>> traverse (\x -> if odd x then Just x else Nothing)  [1,2,3,4]-    -- Nothing-    ---    -- >>> traverse id [Right 1, Right 2, Right 3, Right 4, Left 0]-    -- Left 0-    ---    traverse :: Applicative f => (a -> f b) -> t a -> f (t b)-    {-# INLINE traverse #-}  -- See Note [Inline default methods]-    traverse f = sequenceA . fmap f--    -- | Evaluate each action in the structure from left to right, and-    -- collect the results. For a version that ignores the results-    -- see 'Data.Foldable.sequenceA_'.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- For the first two examples we show sequenceA fully evaluating a-    -- a structure and collecting the results.-    ---    -- >>> sequenceA [Just 1, Just 2, Just 3]-    -- Just [1,2,3]-    ---    -- >>> sequenceA [Right 1, Right 2, Right 3]-    -- Right [1,2,3]-    ---    -- The next two example show 'Nothing' and 'Just' will short circuit-    -- the resulting structure if present in the input. For more context,-    -- check the 'Traversable' instances for 'Either' and 'Maybe'.-    ---    -- >>> sequenceA [Just 1, Just 2, Just 3, Nothing]-    -- Nothing-    ---    -- >>> sequenceA [Right 1, Right 2, Right 3, Left 4]-    -- Left 4-    ---    sequenceA :: Applicative f => t (f a) -> f (t a)-    {-# INLINE sequenceA #-}  -- See Note [Inline default methods]-    sequenceA = traverse id--    -- | Map each element of a structure to a monadic action, evaluate-    -- these actions from left to right, and collect the results. For-    -- a version that ignores the results see 'Data.Foldable.mapM_'.-    ---    -- ==== __Examples__-    ---    -- 'mapM' is literally a 'traverse' with a type signature restricted-    -- to 'Monad'. Its implementation may be more efficient due to additional-    -- power of 'Monad'.-    ---    mapM :: Monad m => (a -> m b) -> t a -> m (t b)-    {-# INLINE mapM #-}  -- See Note [Inline default methods]-    mapM = traverse--    -- | Evaluate each monadic action in the structure from left to-    -- right, and collect the results. For a version that ignores the-    -- results see 'Data.Foldable.sequence_'.-    ---    -- ==== __Examples__-    ---    -- Basic usage:-    ---    -- The first two examples are instances where the input and-    -- and output of 'sequence' are isomorphic.-    ---    -- >>> sequence $ Right [1,2,3,4]-    -- [Right 1,Right 2,Right 3,Right 4]-    ---    -- >>> sequence $ [Right 1,Right 2,Right 3,Right 4]-    -- Right [1,2,3,4]-    ---    -- The following examples demonstrate short circuit behavior-    -- for 'sequence'.-    ---    -- >>> sequence $ Left [1,2,3,4]-    -- Left [1,2,3,4]-    ---    -- >>> sequence $ [Left 0, Right 1,Right 2,Right 3,Right 4]-    -- Left 0-    ---    sequence :: Monad m => t (m a) -> m (t a)-    {-# INLINE sequence #-}  -- See Note [Inline default methods]-    sequence = sequenceA--{- Note [Inline default methods]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--   class ... => Traversable t where-       ...-       mapM :: Monad m => (a -> m b) -> t a -> m (t b)-       mapM = traverse   -- Default method--   instance Traversable [] where-       {-# INLINE traverse #-}-       traverse = ...code for traverse on lists ...--This gives rise to a list-instance of mapM looking like this--  $fTraversable[]_$ctraverse = ...code for traverse on lists...-       {-# INLINE $fTraversable[]_$ctraverse #-}-  $fTraversable[]_$cmapM    = $fTraversable[]_$ctraverse--Now the $ctraverse obediently inlines into the RHS of $cmapM, /but/-that's all!  We get--  $fTraversable[]_$cmapM = ...code for traverse on lists...--with NO INLINE pragma!  This happens even though 'traverse' had an-INLINE pragma because the author knew it should be inlined pretty-vigorously.--Indeed, it turned out that the rhs of $cmapM was just too big to-inline, so all uses of mapM on lists used a terribly inefficient-dictionary-passing style, because of its 'Monad m =>' type.  Disaster!--Solution: add an INLINE pragma on the default method:--   class ... => Traversable t where-       ...-       mapM :: Monad m => (a -> m b) -> t a -> m (t b)-       {-# INLINE mapM #-}     -- VERY IMPORTANT!-       mapM = traverse--}---- instances for Prelude types---- | @since 2.01-instance Traversable Maybe where-    traverse _ Nothing = pure Nothing-    traverse f (Just x) = Just <$> f x---- | @since 2.01-instance Traversable [] where-    {-# INLINE traverse #-} -- so that traverse can fuse-    traverse f = List.foldr cons_f (pure [])-      where cons_f x ys = liftA2 (:) (f x) ys---- | @since 4.9.0.0-instance Traversable NonEmpty where-  traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as)---- | @since 4.7.0.0-instance Traversable (Either a) where-    traverse _ (Left x) = pure (Left x)-    traverse f (Right y) = Right <$> f y---- | @since 4.15-deriving instance Traversable Solo---- | @since 4.7.0.0-instance Traversable ((,) a) where-    traverse f (x, y) = (,) x <$> f y---- | @since 2.01-instance Ix i => Traversable (Array i) where-    traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)---- | @since 4.7.0.0-instance Traversable Proxy where-    traverse _ _ = pure Proxy-    {-# INLINE traverse #-}-    sequenceA _ = pure Proxy-    {-# INLINE sequenceA #-}-    mapM _ _ = pure Proxy-    {-# INLINE mapM #-}-    sequence _ = pure Proxy-    {-# INLINE sequence #-}---- | @since 4.7.0.0-instance Traversable (Const m) where-    traverse _ (Const m) = pure $ Const m---- | @since 4.8.0.0-instance Traversable Dual where-    traverse f (Dual x) = Dual <$> f x---- | @since 4.8.0.0-instance Traversable Sum where-    traverse f (Sum x) = Sum <$> f x---- | @since 4.8.0.0-instance Traversable Product where-    traverse f (Product x) = Product <$> f x---- | @since 4.8.0.0-instance Traversable First where-    traverse f (First x) = First <$> traverse f x---- | @since 4.8.0.0-instance Traversable Last where-    traverse f (Last x) = Last <$> traverse f x---- | @since 4.12.0.0-instance (Traversable f) => Traversable (Alt f) where-    traverse f (Alt x) = Alt <$> traverse f x---- | @since 4.12.0.0-instance (Traversable f) => Traversable (Ap f) where-    traverse f (Ap x) = Ap <$> traverse f x---- | @since 4.9.0.0-instance Traversable ZipList where-    traverse f (ZipList x) = ZipList <$> traverse f x---- | @since 4.9.0.0-deriving instance Traversable Identity----- Instances for GHC.Generics--- | @since 4.9.0.0-instance Traversable U1 where-    traverse _ _ = pure U1-    {-# INLINE traverse #-}-    sequenceA _ = pure U1-    {-# INLINE sequenceA #-}-    mapM _ _ = pure U1-    {-# INLINE mapM #-}-    sequence _ = pure U1-    {-# INLINE sequence #-}---- | @since 4.9.0.0-deriving instance Traversable V1---- | @since 4.9.0.0-deriving instance Traversable Par1---- | @since 4.9.0.0-deriving instance Traversable f => Traversable (Rec1 f)---- | @since 4.9.0.0-deriving instance Traversable (K1 i c)---- | @since 4.9.0.0-deriving instance Traversable f => Traversable (M1 i c f)---- | @since 4.9.0.0-deriving instance (Traversable f, Traversable g) => Traversable (f :+: g)---- | @since 4.9.0.0-deriving instance (Traversable f, Traversable g) => Traversable (f :*: g)---- | @since 4.9.0.0-deriving instance (Traversable f, Traversable g) => Traversable (f :.: g)---- | @since 4.9.0.0-deriving instance Traversable UAddr---- | @since 4.9.0.0-deriving instance Traversable UChar---- | @since 4.9.0.0-deriving instance Traversable UDouble---- | @since 4.9.0.0-deriving instance Traversable UFloat---- | @since 4.9.0.0-deriving instance Traversable UInt---- | @since 4.9.0.0-deriving instance Traversable UWord---- Instance for Data.Ord--- | @since 4.12.0.0-deriving instance Traversable Down---- general functions---- | 'for' is 'traverse' with its arguments flipped. For a version--- that ignores the results see 'Data.Foldable.for_'.-for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)-{-# INLINE for #-}-for = flip traverse---- | 'forM' is 'mapM' with its arguments flipped. For a version that--- ignores the results see 'Data.Foldable.forM_'.-forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)-{-# INLINE forM #-}-forM = flip mapM---- |The 'mapAccumL' function behaves like a combination of 'fmap'--- and 'Data.Foldable.foldl'; it applies a function to each element of a structure,--- passing an accumulating parameter from left to right, and returning--- a final value of this accumulator together with the new structure.------ ==== __Examples__------ Basic usage:------ >>> mapAccumL (\a b -> (a + b, a)) 0 [1..10]--- (55,[0,1,3,6,10,15,21,28,36,45])------ >>> mapAccumL (\a b -> (a <> show b, a)) "0" [1..5]--- ("012345",["0","01","012","0123","01234"])----mapAccumL :: forall t s a b. Traversable t-          => (s -> a -> (s, b)) -> s -> t a -> (s, t b)--- See Note [Function coercion] in Data.Functor.Utils.-mapAccumL f s t = coerce (traverse @t @(StateL s) @a @b) (flip f) t s---- |The 'mapAccumR' function behaves like a combination of 'fmap'--- and 'Data.Foldable.foldr'; it applies a function to each element of a structure,--- passing an accumulating parameter from right to left, and returning--- a final value of this accumulator together with the new structure.------ ==== __Examples__------ Basic usage:------ >>> mapAccumR (\a b -> (a + b, a)) 0 [1..10]--- (55,[54,52,49,45,40,34,27,19,10,0])------ >>> mapAccumR (\a b -> (a <> show b, a)) "0" [1..5]--- ("054321",["05432","0543","054","05","0"])----mapAccumR :: forall t s a b. Traversable t-          => (s -> a -> (s, b)) -> s -> t a -> (s, t b)--- See Note [Function coercion] in Data.Functor.Utils.-mapAccumR f s t = coerce (traverse @t @(StateR s) @a @b) (flip f) t s---- | This function may be used as a value for `fmap` in a `Functor`---   instance, provided that 'traverse' is defined. (Using---   `fmapDefault` with a `Traversable` instance defined only by---   'sequenceA' will result in infinite recursion.)------ @--- 'fmapDefault' f ≡ 'runIdentity' . 'traverse' ('Identity' . f)--- @-fmapDefault :: forall t a b . Traversable t-            => (a -> b) -> t a -> t b-{-# INLINE fmapDefault #-}--- See Note [Function coercion] in Data.Functor.Utils.-fmapDefault = coerce (traverse @t @Identity @a @b)---- | This function may be used as a value for `Data.Foldable.foldMap`--- in a `Foldable` instance.------ @--- 'foldMapDefault' f ≡ 'getConst' . 'traverse' ('Const' . f)--- @-foldMapDefault :: forall t m a . (Traversable t, Monoid m)-               => (a -> m) -> t a -> m-{-# INLINE foldMapDefault #-}--- See Note [Function coercion] in Data.Functor.Utils.-foldMapDefault = coerce (traverse @t @(Const m) @a @())------------------------ $overview------ #overview#--- Traversable structures support element-wise sequencing of 'Applicative'--- effects (thus also 'Monad' effects) to construct new structures of--- __the same shape__ as the input.------ To illustrate what is meant by /same shape/, if the input structure is--- __@[a]@__, each output structure is a list __@[b]@__ of the same length as--- the input.  If the input is a __@Tree a@__, each output __@Tree b@__ has the--- same graph of intermediate nodes and leaves.  Similarly, if the input is a--- 2-tuple __@(x, a)@__, each output is a 2-tuple __@(x, b)@__, and so forth.------ It is in fact possible to decompose a traversable structure __@t a@__ into--- its shape (a.k.a. /spine/) of type __@t ()@__ and its element list--- __@[a]@__.  The original structure can be faithfully reconstructed from its--- spine and element list.------ The implementation of a @Traversable@ instance for a given structure follows--- naturally from its type; see the [Construction](#construction) section for--- details.--- Instances must satisfy the laws listed in the [Laws section](#laws).--- The diverse uses of @Traversable@ structures result from the many possible--- choices of Applicative effects.--- See the [Advanced Traversals](#advanced) section for some examples.------ Every @Traversable@ structure is both a 'Functor' and 'Foldable' because it--- is possible to implement the requisite instances in terms of 'traverse' by--- using 'fmapDefault' for 'fmap' and 'foldMapDefault' for 'foldMap'.  Direct--- fine-tuned implementations of these superclass methods can in some cases be--- more efficient.------------------------ $traverse--- For an 'Applicative' functor __@f@__ and a @Traversable@ functor __@t@__,--- the type signatures of 'traverse' and 'fmap' are rather similar:------ > fmap     :: (a -> f b) -> t a -> t (f b)--- > traverse :: (a -> f b) -> t a -> f (t b)------ The key difference is that 'fmap' produces a structure whose elements (of--- type __@f b@__) are individual effects, while 'traverse' produces an--- aggregate effect yielding structures of type __@t b@__.------ For example, when __@f@__ is the __@IO@__ monad, and __@t@__ is __@List@__,--- 'fmap' yields a list of IO actions, whereas 'traverse' constructs an IO--- action that evaluates to a list of the return values of the individual--- actions performed left-to-right.------ > traverse :: (a -> IO b) -> [a] -> IO [b]------ The 'mapM' function is a specialisation of 'traverse' to the case when--- __@f@__ is a 'Monad'.  For monads, 'mapM' is more idiomatic than 'traverse'.--- The two are otherwise generally identical (though 'mapM' may be specifically--- optimised for monads, and could be more efficient than using the more--- general 'traverse').------ > traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)--- > mapM     :: (Monad       m, Traversable t) => (a -> m b) -> t a -> m (t b)------ When the traversable term is a simple variable or expression, and the--- monadic action to run is a non-trivial do block, it can be more natural to--- write the action last.  This idiom is supported by 'for' and 'forM', which--- are the flipped versions of 'traverse' and 'mapM', respectively.------------------------ $multiplicity------ #multiplicity#--- When 'traverse' or 'mapM' is applied to an empty structure __@ts@__ (one for--- which __@'null' ts@__ is 'True') the return value is __@pure ts@__--- regardless of the provided function __@g :: a -> f b@__.  It is not possible--- to apply the function when no values of type __@a@__ are available, but its--- type determines the relevant instance of 'pure'.------ prop> null ts ==> traverse g ts == pure ts------ Otherwise, when __@ts@__ is non-empty and at least one value of type __@b@__--- results from each __@f a@__, the structures __@t b@__ have /the same shape/--- (list length, graph of tree nodes, ...) as the input structure __@t a@__,--- but the slots previously occupied by elements of type __@a@__ now hold--- elements of type __@b@__.------ A single traversal may produce one, zero or many such structures.  The zero--- case happens when one of the effects __@f a@__ sequenced as part of the--- traversal yields no replacement values.  Otherwise, the many case happens--- when one of sequenced effects yields multiple values.------ The 'traverse' function does not perform selective filtering of slots in the--- output structure as with e.g. 'Data.Maybe.mapMaybe'.------ >>> let incOdd n = if odd n then Just $ n + 1 else Nothing--- >>> mapMaybe incOdd [1, 2, 3]--- [2,4]--- >>> traverse incOdd [1, 3, 5]--- Just [2,4,6]--- >>> traverse incOdd [1, 2, 3]--- Nothing------ In the above examples, with 'Maybe' as the 'Applicative' __@f@__, we see--- that the number of __@t b@__ structures produced by 'traverse' may differ--- from one: it is zero when the result short-circuits to __@Nothing@__.  The--- same can happen when __@f@__ is __@List@__ and the result is __@[]@__, or--- __@f@__ is __@Either e@__ and the result is __@Left (x :: e)@__, or perhaps--- the 'Control.Applicative.empty' value of some--- 'Control.Applicative.Alternative' functor.------ When __@f@__ is e.g. __@List@__, and the map __@g :: a -> [b]@__ returns--- more than one value for some inputs __@a@__ (and at least one for all--- __@a@__), the result of __@mapM g ts@__ will contain multiple structures of--- the same shape as __@ts@__:------ prop> length (mapM g ts) == product (fmap (length . g) ts)------ For example:------ >>> length $ mapM (\n -> [1..n]) [1..6]--- 720--- >>> product $ length . (\n -> [1..n]) <$> [1..6]--- 720------ In other words, a traversal with a function __@g :: a -> [b]@__, over an--- input structure __@t a@__, yields a list __@[t b]@__, whose length is the--- product of the lengths of the lists that @g@ returns for each element of the--- input structure!  The individual elements __@a@__ of the structure are--- replaced by each element of __@g a@__ in turn:------ >>> mapM (\n -> [1..n]) $ Just 3--- [Just 1,Just 2,Just 3]--- >>> mapM (\n -> [1..n]) [1..3]--- [[1,1,1],[1,1,2],[1,1,3],[1,2,1],[1,2,2],[1,2,3]]------ If any element of the structure __@t a@__ is mapped by @g@ to an empty list,--- then the entire aggregate result is empty, because no value is available to--- fill one of the slots of the output structure:------ >>> mapM (\n -> [1..n]) $ [0..6] -- [1..0] is empty--- []------------------------ $effectful--- #effectful#------ The 'traverse' and 'mapM' methods have analogues in the "Data.Foldable"--- module.  These are 'traverse_' and 'mapM_', and their flipped variants--- 'for_' and 'forM_', respectively.  The result type is __@f ()@__, they don't--- return an updated structure, and can be used to sequence effects over all--- the elements of a @Traversable@ (any 'Foldable') structure just for their--- side-effects.------ If the @Traversable@ structure is empty, the result is __@pure ()@__.  When--- effects short-circuit, the __@f ()@__ result may, for example, be 'Nothing'--- if __@f@__ is 'Maybe', or __@'Left' e@__ when it is __@'Either' e@__.------ It is perhaps worth noting that 'Maybe' is not only a potential--- 'Applicative' functor for the return value of the first argument of--- 'traverse', but is also itself a 'Traversable' structure with either zero or--- one element.  A convenient idiom for conditionally executing an action just--- for its effects on a 'Just' value, and doing nothing otherwise is:------ > -- action :: Monad m => a -> m ()--- > -- mvalue :: Maybe a--- > mapM_ action mvalue -- :: m ()------ which is more concise than:------ > maybe (return ()) action mvalue------ The 'mapM_' idiom works verbatim if the type of __@mvalue@__ is later--- refactored from __@Maybe a@__ to __@Either e a@__ (assuming it remains OK to--- silently do nothing in the 'Left' case).------------------------ $sequence------ #sequence#--- The 'sequenceA' and 'sequence' methods are useful when what you have is a--- container of pending applicative or monadic effects, and you want to combine--- them into a single effect that produces zero or more containers with the--- computed values.------ > sequenceA :: (Applicative f, Traversable t) => t (f a) -> f (t a)--- > sequence  :: (Monad       m, Traversable t) => t (m a) -> m (t a)--- > sequenceA = traverse id -- default definition--- > sequence  = sequenceA   -- default definition------ When the monad __@m@__ is 'System.IO.IO', applying 'sequence' to a list of--- IO actions, performs each in turn, returning a list of the results:------ > sequence [putStr "Hello ", putStrLn "World!"]--- >     = (\a b -> [a,b]) <$> putStr "Hello " <*> putStrLn "World!"--- >     = do u1 <- putStr "Hello "--- >          u2 <- putStrLn "World!"--- >          return [u1, u2]         -- In this case  [(), ()]------ For 'sequenceA', the /non-deterministic/ behaviour of @List@ is most easily--- seen in the case of a list of lists (of elements of some common fixed type).--- The result is a cross-product of all the sublists:------ >>> sequenceA [[0, 1, 2], [30, 40], [500]]--- [[0,30,500],[0,40,500],[1,30,500],[1,40,500],[2,30,500],[2,40,500]]------ Because the input list has three (sublist) elements, the result is a list of--- triples (/same shape/).------------------------ $seqshort------ #seqshort#--- When the monad __@m@__ is 'Either' or 'Maybe' (more generally any--- 'Control.Monad.MonadPlus'), the effect in question is to short-circuit the--- result on encountering 'Left' or 'Nothing' (more generally--- 'Control.Monad.mzero').------ >>> sequence [Just 1,Just 2,Just 3]--- Just [1,2,3]--- >>> sequence [Just 1,Nothing,Just 3]--- Nothing--- >>> sequence [Right 1,Right 2,Right 3]--- Right [1,2,3]--- >>> sequence [Right 1,Left "sorry",Right 3]--- Left "sorry"------ The result of 'sequence' is all-or-nothing, either structures of exactly the--- same shape as the input or none at all.  The 'sequence' function does not--- perform selective filtering as with e.g. 'Data.Maybe.catMaybes' or--- 'Data.Either.rights':------ >>> catMaybes [Just 1,Nothing,Just 3]--- [1,3]--- >>> rights [Right 1,Left "sorry",Right 3]--- [1,3]------------------------ $seqdefault------ #seqdefault#--- The 'traverse' method has a default implementation in terms of 'sequenceA':------ > traverse g = sequenceA . fmap g------ but relying on this default implementation is not recommended, it requires--- that the structure is already independently a 'Functor'.  The definition of--- 'sequenceA' in terms of __@traverse id@__ is much simpler than 'traverse'--- expressed via a composition of 'sequenceA' and 'fmap'.  Instances should--- generally implement 'traverse' explicitly.  It may in some cases also make--- sense to implement a specialised 'mapM'.------ Because 'fmapDefault' is defined in terms of 'traverse' (whose default--- definition in terms of 'sequenceA' uses 'fmap'), you must not use--- 'fmapDefault' to define the @Functor@ instance if the @Traversable@ instance--- directly defines only 'sequenceA'.------------------------ $tree_instance------ #tree#--- The definition of a 'Traversable' instance for a binary tree is rather--- similar to the corresponding instance of 'Functor', given the data type:------ > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)------ a canonical @Functor@ instance would be------ > instance Functor Tree where--- >    fmap g Empty        = Empty--- >    fmap g (Leaf x)     = Leaf (g x)--- >    fmap g (Node l k r) = Node (fmap g l) (g k) (fmap g r)------ a canonical @Traversable@ instance would be------ > instance Traversable Tree where--- >    traverse g Empty        = pure Empty--- >    traverse g (Leaf x)     = Leaf <$> g x--- >    traverse g (Node l k r) = Node <$> traverse g l <*> g k <*> traverse g r------ This definition works for any __@g :: a -> f b@__, with __@f@__ an--- Applicative functor, as the laws for @('<*>')@ imply the requisite--- associativity.------ We can add an explicit non-default 'mapM' if desired:------ >    mapM g Empty        = return Empty--- >    mapM g (Leaf x)     = Leaf <$> g x--- >    mapM g (Node l k r) = do--- >        ml <- mapM g l--- >        mk <- g k--- >        mr <- mapM g r--- >        return $ Node ml mk mr------ See [Construction](#construction) below for a more detailed exploration of--- the general case, but as mentioned in [Overview](#overview) above, instance--- definitions are typically rather simple, all the interesting behaviour is a--- result of an interesting choice of 'Applicative' functor for a traversal.---- $tree_order------ It is perhaps worth noting that the traversal defined above gives an--- /in-order/ sequencing of the elements.  If instead you want either--- /pre-order/ (parent first, then child nodes) or post-order (child nodes--- first, then parent) sequencing, you can define the instance accordingly:------ > inOrderNode :: Tree a -> a -> Tree a -> Tree a--- > inOrderNode l x r = Node l x r--- >--- > preOrderNode :: a -> Tree a -> Tree a -> Tree a--- > preOrderNode x l r = Node l x r--- >--- > postOrderNode :: Tree a -> Tree a -> a -> Tree a--- > postOrderNode l r x = Node l x r--- >--- > -- Traversable instance with in-order traversal--- > instance Traversable Tree where--- >     traverse g t = case t of--- >         Empty      -> pure Empty--- >         Leaf x     -> Leaf <$> g x--- >         Node l x r -> inOrderNode <$> traverse g l <*> g x <*> traverse g r--- >--- > -- Traversable instance with pre-order traversal--- > instance Traversable Tree where--- >     traverse g t = case t of--- >         Empty      -> pure Empty--- >         Leaf x     -> Leaf <$> g x--- >         Node l x r -> preOrderNode <$> g x <*> traverse g l <*> traverse g r--- >--- > -- Traversable instance with post-order traversal--- > instance Traversable Tree where--- >     traverse g t = case t of--- >         Empty      -> pure Empty--- >         Leaf x     -> Leaf <$> g x--- >         Node l x r -> postOrderNode <$> traverse g l <*> traverse g r <*> g x------ Since the same underlying Tree structure is used in all three cases, it is--- possible to use @newtype@ wrappers to make all three available at the same--- time!  The user need only wrap the root of the tree in the appropriate--- @newtype@ for the desired traversal order.  Tne associated instance--- definitions are shown below (see [coercion](#coercion) if unfamiliar with--- the use of 'coerce' in the sample code):------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- >--- > -- Default in-order traversal--- >--- > import Data.Coerce (coerce)--- > import Data.Traversable--- >--- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)--- > instance Functor  Tree where fmap    = fmapDefault--- > instance Foldable Tree where foldMap = foldMapDefault--- >--- > instance Traversable Tree where--- >     traverse _ Empty = pure Empty--- >     traverse g (Leaf a) = Leaf <$> g a--- >     traverse g (Node l a r) = Node <$> traverse g l <*> g a <*> traverse g r--- >--- > -- Optional pre-order traversal--- >--- > newtype PreOrderTree a = PreOrderTree (Tree a)--- > instance Functor  PreOrderTree where fmap    = fmapDefault--- > instance Foldable PreOrderTree where foldMap = foldMapDefault--- >--- > instance Traversable PreOrderTree where--- >     traverse _ (PreOrderTree Empty)        = pure $ preOrderEmpty--- >     traverse g (PreOrderTree (Leaf x))     = preOrderLeaf <$> g x--- >     traverse g (PreOrderTree (Node l x r)) = preOrderNode--- >         <$> g x--- >         <*> traverse g (coerce l)--- >         <*> traverse g (coerce r)--- >--- > preOrderEmpty :: forall a. PreOrderTree a--- > preOrderEmpty = coerce (Empty @a)--- > preOrderLeaf :: forall a. a -> PreOrderTree a--- > preOrderLeaf = coerce (Leaf @a)--- > preOrderNode :: a -> PreOrderTree a -> PreOrderTree a -> PreOrderTree a--- > preOrderNode x l r = coerce (Node (coerce l) x (coerce r))--- >--- > -- Optional post-order traversal--- >--- > newtype PostOrderTree a = PostOrderTree (Tree a)--- > instance Functor  PostOrderTree where fmap    = fmapDefault--- > instance Foldable PostOrderTree where foldMap = foldMapDefault--- >--- > instance Traversable PostOrderTree where--- >     traverse _ (PostOrderTree Empty)        = pure postOrderEmpty--- >     traverse g (PostOrderTree (Leaf x))     = postOrderLeaf <$> g x--- >     traverse g (PostOrderTree (Node l x r)) = postOrderNode--- >         <$> traverse g (coerce l)--- >         <*> traverse g (coerce r)--- >         <*> g x--- >--- > postOrderEmpty :: forall a. PostOrderTree a--- > postOrderEmpty = coerce (Empty @a)--- > postOrderLeaf :: forall a. a -> PostOrderTree a--- > postOrderLeaf = coerce (Leaf @a)--- > postOrderNode :: PostOrderTree a -> PostOrderTree a -> a -> PostOrderTree a--- > postOrderNode l r x = coerce (Node (coerce l) x (coerce r))------ With the above, given a sample tree:------ > inOrder :: Tree Int--- > inOrder = Node (Node (Leaf 10) 3 (Leaf 20)) 5 (Leaf 42)------ we have:------ > import Data.Foldable (toList)--- > print $ toList inOrder--- > [10,3,20,5,42]--- >--- > print $ toList (coerce inOrder :: PreOrderTree Int)--- > [5,3,10,20,42]--- >--- > print $ toList (coerce inOrder :: PostOrderTree Int)--- > [10,20,3,42,5]------ You would typically define instances for additional common type classes,--- such as 'Eq', 'Ord', 'Show', etc.------------------------ $construction------ #construction#--- In order to be able to reason about how a given type of 'Applicative'--- effects will be sequenced through a general 'Traversable' structure by its--- 'traversable' and related methods, it is helpful to look more closely--- at how a general 'traverse' method is implemented.  We'll look at how--- general traversals are constructed primarily with a view to being able--- to predict their behaviour as a user, even if you're not defining your--- own 'Traversable' instances.------ Traversable structures __@t a@__ are assembled incrementally from their--- constituent parts, perhaps by prepending or appending individual elements of--- type __@a@__, or, more generally, by recursively combining smaller composite--- traversable building blocks that contain multiple such elements.------ As in the [tree example](#tree) above, the components being combined are--- typically pieced together by a suitable /constructor/, i.e. a function--- taking two or more arguments that returns a composite value.------ The 'traverse' method enriches simple incremental construction with--- threading of 'Applicative' effects of some function __@g :: a -> f b@__.------ The basic building blocks we'll use to model the construction of 'traverse'--- are a hypothetical set of elementary functions, some of which may have--- direct analogues in specific @Traversable@ structures.  For example, the--- __@(':')@__ constructor is an analogue for lists of @prepend@ or the more--- general @combine@.------ > empty :: t a               -- build an empty container--- > singleton :: a -> t a      -- build a one-element container--- > prepend :: a -> t a -> t a -- extend by prepending a new initial element--- > append  :: t a -> a -> t a -- extend by appending a new final element--- > combine :: a1 -> a2 -> ... -> an -> t a -- combine multiple inputs------ * An empty structure has no elements of type __@a@__, so there's nothing---   to which __@g@__ can be applied, but since we need an output of type---   __@f (t b)@__, we just use the 'pure' instance of __@f@__ to wrap an---   empty of type __@t b@__:------     > traverse _ (empty :: t a) = pure (empty :: t b)------     With the List monad, /empty/ is __@[]@__, while with 'Maybe' it is---     'Nothing'.  With __@Either e a@__ we have an /empty/ case for each---     value of __@e@__:------     > traverse _ (Left e :: Either e a) = pure $ (Left e :: Either e b)------ * A singleton structure has just one element of type __@a@__, and---   'traverse' can take that __@a@__, apply __@g :: a -> f b@__ getting an---   __@f b@__, then __@fmap singleton@__ over that, getting an __@f (t b)@__---   as required:------     > traverse g (singleton a) = fmap singleton $ g a------     Note that if __@f@__ is __@List@__ and __@g@__ returns multiple values---     the result will be a list of multiple __@t b@__ singletons!------     Since 'Maybe' and 'Either' are either empty or singletons, we have------     > traverse _ Nothing = pure Nothing---     > traverse g (Just a) = Just <$> g a------     > traverse _ (Left e) = pure (Left e)---     > traverse g (Right a) = Right <$> g a------     For @List@, empty is __@[]@__ and @singleton@ is __@(:[])@__, so we have:------     > traverse _ []  = pure []---     > traverse g [a] = fmap (:[]) (g a)---     >                = (:) <$> (g a) <*> traverse g []---     >                = liftA2 (:) (g a) (traverse g [])------ * When the structure is built by adding one more element via __@prepend@__---   or __@append@__, traversal amounts to:------     > traverse g (prepend a t0) = prepend <$> (g a) <*> traverse g t0---     >                           = liftA2 prepend (g a) (traverse g t0)------     > traverse g (append t0 a) = append <$> traverse g t0 <*> g a---     >                          = liftA2 append (traverse g t0) (g a)------     The origin of the combinatorial product when __@f@__ is @List@ should now---     be apparent, when __@traverse g t0@__ has __@n@__ elements and __@g a@__---     has __@m@__ elements, the /non-deterministic/ 'Applicative' instance of---     @List@ will produce a result with __@m * n@__ elements.------ * When combining larger building blocks, we again use __@('<*>')@__ to---   combine the traversals of the components.  With bare elements __@a@__---   mapped to __@f b@__ via __@g@__, and composite traversable---   sub-structures transformed via __@traverse g@__:------     > traverse g (combine a1 a2 ... an) =---     >     combine <$> t1 <*> t2 <*> ... <*> tn---     >   where---     >      t1 = g a1          -- if a1 fills a slot of type @a@---     >         = traverse g a1 -- if a1 is a traversable substructure---     >      ... ditto for the remaining constructor arguments ...------ The above definitions sequence the 'Applicative' effects of __@f@__ in the--- expected order while producing results of the expected shape __@t@__.------ For lists this becomes:------ > traverse g [] = pure []--- > traverse g (x:xs) = liftA2 (:) (g a) (traverse g xs)------ The actual definition of 'traverse' for lists is an equivalent--- right fold in order to facilitate list /fusion/.------ > traverse g = foldr (\x r -> liftA2 (:) (g x) r) (pure [])------------------------ $advanced------ #advanced#--- In the sections below we'll examine some advanced choices of 'Applicative'--- effects that give rise to very different transformations of @Traversable@--- structures.------ These examples cover the implementations of 'fmapDefault', 'foldMapDefault',--- 'mapAccumL' and 'mapAccumR' functions illustrating the use of 'Identity',--- 'Const' and stateful 'Applicative' effects.  The [ZipList](#ziplist) example--- illustrates the use of a less-well known 'Applicative' instance for lists.------ This is optional material, which is not essential to a basic understanding of--- @Traversable@ structures.  If this is your first encounter with @Traversable@--- structures, you can come back to these at a later date.---- $coercion------ #coercion#--- Some of the examples make use of an advanced Haskell feature, namely--- @newtype@ /coercion/.  This is done for two reasons:------ * Use of 'coerce' makes it possible to avoid cluttering the code with---   functions that wrap and unwrap /newtype/ terms, which at runtime are---   indistinguishable from the underlying value.  Coercion is particularly---   convenient when one would have to otherwise apply multiple newtype---   constructors to function arguments, and then peel off multiple layers---   of same from the function output.------ * Use of 'coerce' can produce more efficient code, by reusing the original---   value, rather than allocating space for a wrapped clone.------ If you're not familiar with 'coerce', don't worry, it is just a shorthand--- that, e.g., given:------ > newtype Foo a = MkFoo { getFoo :: a }--- > newtype Bar a = MkBar { getBar :: a }--- > newtype Baz a = MkBaz { getBaz :: a }--- > f :: Baz Int -> Bar (Foo String)------ makes it possible to write:------ > x :: Int -> String--- > x = coerce f------ instead of------ > x = getFoo . getBar . f . MkBaz------------------------ $identity------ #identity#--- The simplest Applicative functor is 'Identity', which just wraps and unwraps--- pure values and function application.  This allows us to define--- 'fmapDefault':------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- > import Data.Coercible (coerce)--- >--- > fmapDefault :: forall t a b. Traversable t => (a -> b) -> t a -> t b--- > fmapDefault = coerce (traverse @t @Identity @a @b)------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap terms via 'Identity' and 'runIdentity'.------ As noted in [Overview](#overview), 'fmapDefault' can only be used to define--- the requisite 'Functor' instance of a 'Traversable' structure when the--- 'traverse' method is explicitly implemented.  An infinite loop would result--- if in addition 'traverse' were defined in terms of 'sequenceA' and 'fmap'.------------------------ $stateful------ #stateful#--- Applicative functors that thread a changing state through a computation are--- an interesting use-case for 'traverse'.  The 'mapAccumL' and 'mapAccumR'--- functions in this module are each defined in terms of such traversals.------ We first define a simplified (not a monad transformer) version of--- 'Control.Monad.Trans.State.State' that threads a state __@s@__ through a--- chain of computations left to right.  Its @('<*>')@ operator passes the--- input state first to its left argument, and then the resulting state is--- passed to its right argument, which returns the final state.------ > newtype StateL s a = StateL { runStateL :: s -> (s, a) }--- >--- > instance Functor (StateL s) where--- >     fmap f (StateL kx) = StateL $ \ s ->--- >         let (s', x) = kx s in (s', f x)--- >--- > instance Applicative (StateL s) where--- >     pure a = StateL $ \s -> (s, a)--- >     (StateL kf) <*> (StateL kx) = StateL $ \ s ->--- >         let { (s',  f) = kf s--- >             ; (s'', x) = kx s' } in (s'', f x)--- >     liftA2 f (StateL kx) (StateL ky) = StateL $ \ s ->--- >         let { (s',  x) = kx s--- >             ; (s'', y) = ky s' } in (s'', f x y)------ With @StateL@, we can define 'mapAccumL' as follows:------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- > mapAccumL :: forall t s a b. Traversable t--- >           => (s -> a -> (s, b)) -> s -> t a -> (s, t b)--- > mapAccumL g s ts = coerce (traverse @t @(StateL s) @a @b) (flip g) ts s------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap __@newtype@__ terms.------ The type of __@flip g@__ is coercible to __@a -> StateL b@__, which makes it--- suitable for use with 'traverse'.  As part of the Applicative--- [construction](#construction) of __@StateL (t b)@__ the state updates will--- thread left-to-right along the sequence of elements of __@t a@__.------ While 'mapAccumR' has a type signature identical to 'mapAccumL', it differs--- in the expected order of evaluation of effects, which must take place--- right-to-left.------ For this we need a variant control structure @StateR@, which threads the--- state right-to-left, by passing the input state to its right argument and--- then using the resulting state as an input to its left argument:------ > newtype StateR s a = StateR { runStateR :: s -> (s, a) }--- >--- > instance Functor (StateR s) where--- >     fmap f (StateR kx) = StateR $ \s ->--- >         let (s', x) = kx s in (s', f x)--- >--- > instance Applicative (StateR s) where--- >     pure a = StateR $ \s -> (s, a)--- >     (StateR kf) <*> (StateR kx) = StateR $ \ s ->--- >         let { (s',  x) = kx s--- >             ; (s'', f) = kf s' } in (s'', f x)--- >     liftA2 f (StateR kx) (StateR ky) = StateR $ \ s ->--- >         let { (s',  y) = ky s--- >             ; (s'', x) = kx s' } in (s'', f x y)------ With @StateR@, we can define 'mapAccumR' as follows:------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- > mapAccumR :: forall t s a b. Traversable t--- >           => (s -> a -> (s, b)) -> s -> t a -> (s, t b)--- > mapAccumR g s0 ts = coerce (traverse @t @(StateR s) @a @b) (flip g) ts s0------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap __@newtype@__ terms.------ Various stateful traversals can be constructed from 'mapAccumL' and--- 'mapAccumR' for suitable choices of @g@, or built directly along similar--- lines.------------------------ $phantom------ #phantom#--- The 'Const' Functor enables applications of 'traverse' that summarise the--- input structure to an output value without constructing any output values--- of the same type or shape.------ As noted [above](#overview), the @Foldable@ superclass constraint is--- justified by the fact that it is possible to construct 'foldMap', 'foldr',--- etc., from 'traverse'.  The technique used is useful in its own right, and--- is explored below.------ A key feature of folds is that they can reduce the input structure to a--- summary value. Often neither the input structure nor a mutated clone is--- needed once the fold is computed, and through list fusion the input may not--- even have been memory resident in its entirety at the same time.------ The 'traverse' method does not at first seem to be a suitable building block--- for folds, because its return value __@f (t b)@__ appears to retain mutated--- copies of the input structure.  But the presence of __@t b@__ in the type--- signature need not mean that terms of type __@t b@__ are actually embedded--- in __@f (t b)@__.  The simplest way to elide the excess terms is by basing--- the Applicative functor used with 'traverse' on 'Const'.------ Not only does __@Const a b@__ hold just an __@a@__ value, with the __@b@__--- parameter merely a /phantom/ type, but when __@m@__ has a 'Monoid' instance,--- __@Const m@__ is an 'Applicative' functor:------ > import Data.Coerce (coerce)--- > newtype Const a b = Const { getConst :: a } deriving (Eq, Ord, Show) -- etc.--- > instance Functor (Const m) where fmap = const coerce--- > instance Monoid m => Applicative (Const m) where--- >    pure _   = Const mempty--- >    (<*>)    = coerce (mappend :: m -> m -> m)--- >    liftA2 _ = coerce (mappend :: m -> m -> m)------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap __@newtype@__ terms.------ We can therefore define a specialisation of 'traverse':------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- > traverseC :: forall t a m. (Monoid m, Traversable t)--- >           => (a -> Const m ()) -> t a -> Const m (t ())--- > traverseC = traverse @t @(Const m) @a @()------ For which the Applicative [construction](#construction) of 'traverse'--- leads to:------ prop> null ts ==> traverseC g ts = Const mempty--- prop> traverseC g (prepend x xs) = Const (g x) <> traverseC g xs------ In other words, this makes it possible to define:------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- > foldMapDefault :: forall t a m. (Monoid m, Traversable t) => (a -> m) -> t a -> m--- > foldMapDefault = coerce (traverse @t @(Const m) @a @())------ Which is sufficient to define a 'Foldable' superclass instance:------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap __@newtype@__ terms.------ > instance Traversable t => Foldable t where foldMap = foldMapDefault------ It may however be instructive to also directly define candidate default--- implementations of 'foldr' and 'foldl'', which take a bit more machinery--- to construct:------ > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}--- > import Data.Coerce (coerce)--- > import Data.Functor.Const (Const(..))--- > import Data.Semigroup (Dual(..), Endo(..))--- > import GHC.Exts (oneShot)--- >--- > foldrDefault :: forall t a b. Traversable t--- >              => (a -> b -> b) -> b -> t a -> b--- > foldrDefault f z = \t ->--- >     coerce (traverse @t @(Const (Endo b)) @a @()) f t z--- >--- > foldlDefault' :: forall t a b. Traversable t => (b -> a -> b) -> b -> t a -> b--- > foldlDefault' f z = \t ->--- >     coerce (traverse @t @(Const (Dual (Endo b))) @a @()) f' t z--- >   where--- >     f' :: a -> b -> b--- >     f' a = oneShot $ \ b -> b `seq` f b a------ In the above we're using the __@'Data.Monoid.Endo' b@__ 'Monoid' and its--- 'Dual' to compose a sequence of __@b -> b@__ accumulator updates in either--- left-to-right or right-to-left order.------ The use of 'seq' in the definition of __@foldlDefault'@__ ensures strictness--- in the accumulator.------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap __@newtype@__ terms.------ The 'GHC.Exts.oneShot' function gives a hint to the compiler that aids in--- correct optimisation of lambda terms that fire at most once (for each--- element __@a@__) and so should not try to pre-compute and re-use--- subexpressions that pay off only on repeated execution.  Otherwise, it is--- just the identity function.------------------------ $ziplist------ #ziplist#--- As a warm-up for looking at the 'ZipList' 'Applicative' functor, we'll first--- look at a simpler analogue.  First define a fixed width 2-element @Vec2@--- type, whose 'Applicative' instance combines a pair of functions with a pair of--- values by applying each function to the corresponding value slot:------ > data Vec2 a = Vec2 a a--- > instance Functor Vec2 where--- >     fmap f (Vec2 a b) = Vec2 (f a) (f b)--- > instance Applicative Vec2 where--- >     pure x = Vec2 x x--- >     liftA2 f (Vec2 a b) (Vec2 p q) = Vec2 (f a p) (f b q)--- > instance Foldable Vec2 where--- >     foldr f z (Vec2 a b) = f a (f b z)--- >     foldMap f (Vec2 a b) = f a <> f b--- > instance Traversable Vec2 where--- >     traverse f (Vec2 a b) = Vec2 <$> f a <*> f b------ Along with a similar definition for fixed width 3-element vectors:------ > data Vec3 a = Vec3 a a a--- > instance Functor Vec3 where--- >     fmap f (Vec3 x y z) = Vec3 (f x) (f y) (f z)--- > instance Applicative Vec3 where--- >     pure x = Vec3 x x x--- >     liftA2 f (Vec3 p q r) (Vec3 x y z) = Vec3 (f p x) (f q y) (f r z)--- > instance Foldable Vec3 where--- >     foldr f z (Vec3 a b c) = f a (f b (f c z))--- >     foldMap f (Vec3 a b c) = f a <> f b <> f c--- > instance Traversable Vec3 where--- >     traverse f (Vec3 a b c) = Vec3 <$> f a <*> f b <*> f c------ With the above definitions, @'sequenceA'@ (same as @'traverse' 'id'@) acts--- as a /matrix transpose/ operation on @Vec2 (Vec3 Int)@ producing a--- corresponding @Vec3 (Vec2 Int)@:------ Let __@t = Vec2 (Vec3 1 2 3) (Vec3 4 5 6)@__ be our 'Traversable' structure,--- and __@g = id :: Vec3 Int -> Vec3 Int@__ be the function used to traverse--- __@t@__.  We then have:------ > traverse g t = Vec2 <$> (Vec3 1 2 3) <*> (Vec3 4 5 6)--- >              = Vec3 (Vec2 1 4) (Vec2 2 5) (Vec2 3 6)------ This construction can be generalised from fixed width vectors to variable--- length lists via 'Control.Applicative.ZipList'.  This gives a transpose--- operation that works well for lists of equal length.  If some of the lists--- are longer than others, they're truncated to the longest common length.------ We've already looked at the standard 'Applicative' instance of @List@ for--- which applying __@m@__ functions __@f1, f2, ..., fm@__ to __@n@__ input--- values __@a1, a2, ..., an@__ produces __@m * n@__ outputs:------ >>> :set -XTupleSections--- >>> [("f1",), ("f2",), ("f3",)] <*> [1,2]--- [("f1",1),("f1",2),("f2",1),("f2",2),("f3",1),("f3",2)]------ There are however two more common ways to turn lists into 'Applicative'--- control structures.  The first is via __@'Const' [a]@__, since lists are--- monoids under concatenation, and we've already seen that __@'Const' m@__ is--- an 'Applicative' functor when __@m@__ is a 'Monoid'.  The second, is based--- on 'Data.List.zipWith', and is called 'Control.Applicative.ZipList':------ > {-# LANGUAGE GeneralizedNewtypeDeriving #-}--- > newtype ZipList a = ZipList { getZipList :: [a] }--- >     deriving (Show, Eq, ..., Functor)--- >--- > instance Applicative ZipList where--- >     liftA2 f (ZipList xs) (ZipList ys) = ZipList $ zipWith f xs ys--- >     pure x = repeat x------ The 'liftA2' definition is clear enough, instead of applying __@f@__ to each--- pair __@(x, y)@__ drawn independently from the __@xs@__ and __@ys@__, only--- corresponding pairs at each index in the two lists are used.------ The definition of 'pure' may look surprising, but it is needed to ensure--- that the instance is lawful:------ prop> liftA2 f (pure x) ys == fmap (f x) ys------ Since __@ys@__ can have any length, we need to provide an infinite supply--- of __@x@__ values in __@pure x@__ in order to have a value to pair with--- each element __@y@__.------ When 'Control.Applicative.ZipList' is the 'Applicative' functor used in the--- [construction](#construction) of a traversal, a ZipList holding a partially--- built structure with __@m@__ elements is combined with a component holding--- __@n@__ elements via 'zipWith', resulting in __@min m n@__ outputs!------ Therefore 'traverse' with __@g :: a -> ZipList b@__ will produce a @ZipList@--- of __@t b@__ structures whose element count is the minimum length of the--- ZipLists __@g a@__ with __@a@__ ranging over the elements of __@t@__.  When--- __@t@__ is empty, the length is infinite (as expected for a minimum of an--- empty set).------ If the structure __@t@__ holds values of type __@ZipList a@__, we can use--- the identity function __@id :: ZipList a -> ZipList a@__ for the first--- argument of 'traverse':------ > traverse (id :: ZipList a -> ZipList a) :: t (ZipList a) -> ZipList (t a)------ The number of elements in the output @ZipList@ will be the length of the--- shortest @ZipList@ element of __@t@__.  Each output __@t a@__ will have the--- /same shape/ as the input __@t (ZipList a)@__, i.e. will share its number of--- elements.------ If we think of the elements of __@t (ZipList a)@__ as its rows, and the--- elements of each individual @ZipList@ as the columns of that row, we see--- that our traversal implements a /transpose/ operation swapping the rows--- and columns of __@t@__, after first truncating all the rows to the column--- count of the shortest one.------ Since in fact __@'traverse' id@__ is just 'sequenceA' the above boils down--- to a rather concise definition of /transpose/, with [coercion](#coercion)--- used to implicily wrap and unwrap the @ZipList@ @newtype@ as neeed, giving--- a function that operates on a list of lists:------ >>> {-# LANGUAGE ScopedTypeVariables #-}--- >>> import Control.Applicative (ZipList(..))--- >>> import Data.Coerce (coerce)--- >>>--- >>> transpose :: forall a. [[a]] -> [[a]]--- >>> transpose = coerce (sequenceA :: [ZipList a] -> ZipList [a])--- >>>--- >>> transpose [[1,2,3],[4..],[7..]]--- [[1,4,7],[2,5,8],[3,6,9]]------ The use of [coercion](#coercion) avoids the need to explicitly wrap and--- unwrap __@ZipList@__ terms.------------------------ $laws------ #laws#--- A definition of 'traverse' must satisfy the following laws:------ [Naturality]---   @t . 'traverse' f = 'traverse' (t . f)@---   for every applicative transformation @t@------ [Identity]---   @'traverse' 'Identity' = 'Identity'@------ [Composition]---   @'traverse' ('Data.Functor.Compose.Compose' . 'fmap' g . f)---     = 'Data.Functor.Compose.Compose' . 'fmap' ('traverse' g) . 'traverse' f@------ A definition of 'sequenceA' must satisfy the following laws:------ [Naturality]---   @t . 'sequenceA' = 'sequenceA' . 'fmap' t@---   for every applicative transformation @t@------ [Identity]---   @'sequenceA' . 'fmap' 'Identity' = 'Identity'@------ [Composition]---   @'sequenceA' . 'fmap' 'Data.Functor.Compose.Compose'---     = 'Data.Functor.Compose.Compose' . 'fmap' 'sequenceA' . 'sequenceA'@------ where an /applicative transformation/ is a function------ @t :: (Applicative f, Applicative g) => f a -> g a@------ preserving the 'Applicative' operations, i.e.------ @--- t ('pure' x) = 'pure' x--- t (f '<*>' x) = t f '<*>' t x--- @------ and the identity functor 'Identity' and composition functors--- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and--- "Data.Functor.Compose".------ A result of the naturality law is a purity law for 'traverse'------ @'traverse' 'pure' = 'pure'@------ (The naturality law is implied by parametricity and thus so is the--- purity law [1, p15].)------ The superclass instances should satisfy the following:------  * In the 'Functor' instance, 'fmap' should be equivalent to traversal---    with the identity applicative functor ('fmapDefault').------  * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be---    equivalent to traversal with a constant applicative functor---    ('foldMapDefault').------ Note: the 'Functor' superclass means that (in GHC) Traversable structures--- cannot impose any constraints on the element type.  A Haskell implementation--- that supports constrained functors could make it possible to define--- constrained @Traversable@ structures.------------------------ $also------  * [1] \"The Essence of the Iterator Pattern\",---    by Jeremy Gibbons and Bruno Oliveira,---    in /Mathematically-Structured Functional Programming/, 2006, online at---    <http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/#iterator>.------  * \"Applicative Programming with Effects\",---    by Conor McBride and Ross Paterson,---    /Journal of Functional Programming/ 18:1 (2008) 1-13, online at---    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.------  * \"An Investigation of the Laws of Traversals\",---    by Mauro Jaskelioff and Ondrej Rypacek,---    in /Mathematically-Structured Functional Programming/, 2012, online at---    <http://arxiv.org/pdf/1202.2919>.
− Data/Tuple.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Tuple--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Functions associated with the tuple data types.-----------------------------------------------------------------------------------module Data.Tuple-  ( Solo (..)-  , fst-  , snd-  , curry-  , uncurry-  , swap-  ) where--import GHC.Base ()      -- Note [Depend on GHC.Tuple]-import GHC.Tuple (Solo (..))--default ()              -- Double isn't available yet---- ------------------------------------------------------------------------------ Standard functions over tuples---- | Extract the first component of a pair.-fst                     :: (a,b) -> a-fst (x,_)               =  x---- | Extract the second component of a pair.-snd                     :: (a,b) -> b-snd (_,y)               =  y---- | 'curry' converts an uncurried function to a curried function.------ ==== __Examples__------ >>> curry fst 1 2--- 1-curry                   :: ((a, b) -> c) -> a -> b -> c-curry f x y             =  f (x, y)---- | 'uncurry' converts a curried function to a function on pairs.------ ==== __Examples__------ >>> uncurry (+) (1,2)--- 3------ >>> uncurry ($) (show, 1)--- "1"------ >>> map (uncurry max) [(1,2), (3,4), (6,8)]--- [2,4,8]-uncurry                 :: (a -> b -> c) -> ((a, b) -> c)-uncurry f p             =  f (fst p) (snd p)---- | Swap the components of a pair.-swap                    :: (a,b) -> (b,a)-swap (a,b)              = (b,a)---- $setup--- >>> import Prelude hiding (curry, uncurry, fst, snd)
− Data/Type/Bool.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Type.Bool--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  not portable------ Basic operations on type-level Booleans.------ @since 4.7.0.0--------------------------------------------------------------------------------module Data.Type.Bool (-  If, type (&&), type (||), Not-  ) where--import Data.Bool---- This needs to be in base because (&&) is used in Data.Type.Equality.--- The other functions do not need to be in base, but seemed to be appropriate--- here.---- | 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---- | Type-level "and"-type family a && b where-  'False && a      = 'False-  'True  && a      = a-  a      && 'False = 'False-  a      && 'True  = a-  a      && a      = a-infixr 3 &&---- | Type-level "or"-type family a || b where-  'False || a      = a-  'True  || a      = 'True-  a      || 'False = a-  a      || 'True  = 'True-  a      || a      = a-infixr 2 ||---- | Type-level "not". An injective type family since @4.10.0.0@.------ @since 4.7.0.0-type family Not a = res | res -> a where-  Not 'False = 'True-  Not 'True  = 'False
− Data/Type/Coercion.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE PolyKinds           #-}-{-# LANGUAGE RankNTypes          #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Type.Coercion--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  not portable------ Definition of representational equality ('Coercion').------ @since 4.7.0.0--------------------------------------------------------------------------------module Data.Type.Coercion-  ( Coercion(..)-  , coerceWith-  , gcoerceWith-  , sym-  , trans-  , repr-  , TestCoercion(..)-  ) where--import qualified Data.Type.Equality as Eq-import Data.Maybe-import GHC.Enum-import GHC.Show-import GHC.Read-import GHC.Base---- | Representational equality. If @Coercion a b@ is inhabited by some terminating--- value, then the type @a@ has the same underlying representation as the type @b@.------ To use this equality in practice, pattern-match on the @Coercion a b@ to get out--- the @Coercible a b@ instance, and then use 'coerce' to apply it.------ @since 4.7.0.0-data Coercion a b where-  Coercion :: Coercible a b => Coercion a b---- with credit to Conal Elliott for 'ty', Erik Hesselink & Martijn van--- Steenbergen for 'type-equality', Edward Kmett for 'eq', and Gabor Greif--- for 'type-eq'---- | Type-safe cast, using representational equality-coerceWith :: Coercion a b -> a -> b-coerceWith Coercion x = coerce x---- | Generalized form of type-safe cast using representational equality------ @since 4.10.0.0-gcoerceWith :: Coercion a b -> (Coercible a b => r) -> r-gcoerceWith Coercion x = x---- | Symmetry of representational equality-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 Coercion Coercion = Coercion---- | Convert propositional (nominal) equality to representational equality-repr :: (a Eq.:~: b) -> Coercion a b-repr Eq.Refl = Coercion---- | @since 4.7.0.0-deriving instance Eq   (Coercion a b)---- | @since 4.7.0.0-deriving instance Show (Coercion a b)---- | @since 4.7.0.0-deriving instance Ord  (Coercion a b)---- | @since 4.7.0.0-deriving instance Coercible a b => Read (Coercion a b)---- | @since 4.7.0.0-instance Coercible a b => Enum (Coercion a b) where-  toEnum 0 = Coercion-  toEnum _ = errorWithoutStackTrace "Data.Type.Coercion.toEnum: bad argument"--  fromEnum Coercion = 0---- | @since 4.7.0.0-deriving instance Coercible a b => Bounded (Coercion a b)---- | This class contains types where you can learn the equality of two types--- from information contained in /terms/. Typically, only singleton types should--- inhabit this class.-class TestCoercion f where-  -- | Conditionally prove the representational equality of @a@ and @b@.-  testCoercion :: f a -> f b -> Maybe (Coercion a b)---- | @since 4.7.0.0-instance TestCoercion ((Eq.:~:) a) where-  testCoercion Eq.Refl Eq.Refl = Just Coercion---- | @since 4.10.0.0-instance TestCoercion ((Eq.:~~:) a) where-  testCoercion Eq.HRefl Eq.HRefl = Just Coercion---- | @since 4.7.0.0-instance TestCoercion (Coercion a) where-  testCoercion Coercion Coercion = Just Coercion
− Data/Type/Equality.hs 
@@ -1,206 +0,0 @@-{-# LANGUAGE DataKinds                #-}-{-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE GADTs                    #-}-{-# LANGUAGE MultiParamTypeClasses    #-}-{-# LANGUAGE NoImplicitPrelude        #-}-{-# LANGUAGE PolyKinds                #-}-{-# LANGUAGE RankNTypes               #-}-{-# LANGUAGE StandaloneDeriving       #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE Trustworthy              #-}-{-# LANGUAGE TypeFamilies             #-}-{-# LANGUAGE TypeOperators            #-}-{-# LANGUAGE UndecidableInstances     #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Type.Equality--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  not portable------ Definition of propositional equality @(':~:')@. Pattern-matching on a variable--- of type @(a ':~:' b)@ produces a proof that @a '~' b@.------ @since 4.7.0.0----------------------------------------------------------------------------------module Data.Type.Equality (-  -- * The equality types-  (:~:)(..), type (~~),-  (:~~:)(..),--  -- * Working with equality-  sym, trans, castWith, gcastWith, apply, inner, outer,--  -- * Inferring equality from other types-  TestEquality(..),--  -- * Boolean type-level equality-  type (==)-  ) where--import Data.Maybe-import GHC.Enum-import GHC.Show-import GHC.Read-import GHC.Base-import Data.Type.Bool--infix 4 :~:, :~~:---- | Propositional equality. If @a :~: b@ is inhabited by some terminating--- value, then the type @a@ is the same as the type @b@. To use this equality--- in practice, pattern-match on the @a :~: b@ to get out the @Refl@ constructor;--- in the body of the pattern-match, the compiler knows that @a ~ b@.------ @since 4.7.0.0-data a :~: b where  -- See Note [The equality types story] in GHC.Builtin.Types.Prim-  Refl :: a :~: a---- with credit to Conal Elliott for 'ty', Erik Hesselink & Martijn van--- Steenbergen for 'type-equality', Edward Kmett for 'eq', and Gabor Greif--- for 'type-eq'---- | Symmetry of equality-sym :: (a :~: b) -> (b :~: a)-sym Refl = Refl---- | Transitivity of equality-trans :: (a :~: b) -> (b :~: c) -> (a :~: c)-trans Refl Refl = Refl---- | Type-safe cast, using propositional equality-castWith :: (a :~: b) -> a -> b-castWith Refl x = x---- | Generalized form of type-safe cast using propositional equality-gcastWith :: (a :~: b) -> ((a ~ b) => r) -> r-gcastWith Refl x = x---- | Apply one equality to another, respectively-apply :: (f :~: g) -> (a :~: b) -> (f a :~: g b)-apply Refl Refl = Refl---- | Extract equality of the arguments from an equality of applied types-inner :: (f a :~: g b) -> (a :~: b)-inner Refl = Refl---- | Extract equality of type constructors from an equality of applied types-outer :: (f a :~: g b) -> (f :~: g)-outer Refl = Refl---- | @since 4.7.0.0-deriving instance Eq   (a :~: b)---- | @since 4.7.0.0-deriving instance Show (a :~: b)---- | @since 4.7.0.0-deriving instance Ord  (a :~: b)---- | @since 4.7.0.0-deriving instance a ~ b => Read (a :~: b)---- | @since 4.7.0.0-instance a ~ b => Enum (a :~: b) where-  toEnum 0 = Refl-  toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument"--  fromEnum Refl = 0---- | @since 4.7.0.0-deriving instance a ~ b => Bounded (a :~: b)---- | Kind heterogeneous propositional equality. Like ':~:', @a :~~: b@ is--- inhabited by a terminating value if and only if @a@ is the same type as @b@.------ @since 4.10.0.0-type (:~~:) :: k1 -> k2 -> Type-data a :~~: b where-   HRefl :: a :~~: a---- | @since 4.10.0.0-deriving instance Eq   (a :~~: b)--- | @since 4.10.0.0-deriving instance Show (a :~~: b)--- | @since 4.10.0.0-deriving instance Ord  (a :~~: b)---- | @since 4.10.0.0-deriving instance a ~~ b => Read (a :~~: b)---- | @since 4.10.0.0-instance a ~~ b => Enum (a :~~: b) where-  toEnum 0 = HRefl-  toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument"--  fromEnum HRefl = 0---- | @since 4.10.0.0-deriving instance a ~~ b => Bounded (a :~~: b)---- | This class contains types where you can learn the equality of two types--- from information contained in /terms/. Typically, only singleton types should--- inhabit this class.-class TestEquality f where-  -- | Conditionally prove the equality of @a@ and @b@.-  testEquality :: f a -> f b -> Maybe (a :~: b)---- | @since 4.7.0.0-instance TestEquality ((:~:) a) where-  testEquality Refl Refl = Just Refl---- | @since 4.10.0.0-instance TestEquality ((:~~:) a) where-  testEquality HRefl HRefl = Just Refl--infix 4 ==---- | A type family to compute Boolean equality.-type (==) :: k -> k -> Bool-type family a == b where-  f a == g b = f == g && a == b-  a == a = 'True-  _ == _ = 'False---- The idea here is to recognize equality of *applications* using--- the first case, and of *constructors* using the second and third--- ones. It would be wonderful if GHC recognized that the--- first and second cases are compatible, which would allow us to--- prove------ a ~ b => a == b------ but it (understandably) does not.------ It is absolutely critical that the three cases occur in precisely--- this order. In particular, if------ a == a = 'True------ came first, then the type application case would only be reached--- (uselessly) when GHC discovered that the types were not equal.------ One might reasonably ask what's wrong with a simpler version:------ type family (a :: k) == (b :: k) where---  a == a = True---  a == b = False------ Consider--- data Nat = Zero | Succ Nat------ Suppose I want--- foo :: (Succ n == Succ m) ~ True => ((n == m) :~: True)--- foo = Refl------ This would not type-check with the simple version. `Succ n == Succ m`--- is stuck. We don't know enough about `n` and `m` to reduce the family.--- With the recursive version, `Succ n == Succ m` reduces to--- `Succ == Succ && n == m`, which can reduce to `'True && n == m` and--- finally to `n == m`.
− Data/Type/Ord.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Type.Ord--- License     :  BSD-style (see the LICENSE file in the distribution)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  not portable------ Basic operations on type-level Orderings.------ @since 4.16.0.0--------------------------------------------------------------------------------module Data.Type.Ord (-  Compare, OrderingI(..)-  , type (<=), type (<=?)-  , type (>=), type (>=?)-  , type (>), type (>?)-  , type (<), type (<?)-  , Max, Min-  , OrdCond-  ) where--import GHC.Show(Show(..))-import GHC.TypeLits.Internal-import GHC.TypeNats.Internal-import Data.Bool-import Data.Char(Char)-import Data.Eq-import Data.Ord---- | 'Compare' branches on the kind of its arguments to either compare by--- 'Symbol' or 'Nat'.------ @since 4.16.0.0-type Compare :: k -> k -> Ordering-type family Compare (a :: k) (b :: k) :: Ordering--type instance Compare (a :: Natural) b = CmpNat    a b-type instance Compare (a :: Symbol)  b = CmpSymbol a b-type instance Compare (a :: Char)    b = CmpChar   a b---- | Ordering data type for type literals that provides proof of their ordering.------ @since 4.16.0.0-data OrderingI a b where-  LTI :: Compare a b ~ 'LT => OrderingI a b-  EQI :: Compare a a ~ 'EQ => OrderingI a a-  GTI :: Compare a b ~ 'GT => OrderingI a b--deriving instance Show (OrderingI a b)-deriving instance Eq   (OrderingI a b)---infix 4 <=?, <=, >=?, >=, <?, <, >?, >---- | Comparison (<=) of comparable types, as a constraint.------ @since 4.16.0.0-type x <= y = (x <=? y) ~ 'True---- | Comparison (>=) of comparable types, as a constraint.------ @since 4.16.0.0-type x >= y = (x >=? y) ~ 'True---- | Comparison (<) of comparable types, as a constraint.------ @since 4.16.0.0-type x < y = (x <? y) ~ 'True---- | Comparison (>) of comparable types, as a constraint.------ @since 4.16.0.0-type x > y = (x >? y) ~ 'True----- | Comparison (<=) of comparable types, as a function.------ @since 4.16.0.0-type (<=?) :: k -> k -> Bool-type m <=? n = OrdCond (Compare m n) 'True 'True 'False---- | Comparison (>=) of comparable types, as a function.------ @since 4.16.0.0-type (>=?) :: k -> k -> Bool-type m >=? n = OrdCond (Compare m n) 'False 'True 'True---- | Comparison (<) of comparable types, as a function.------ @since 4.16.0.0-type (<?) :: k -> k -> Bool-type m <? n = OrdCond (Compare m n) 'True 'False 'False---- | Comparison (>) of comparable types, as a function.------ @since 4.16.0.0-type (>?) :: k -> k -> Bool-type m >? n = OrdCond (Compare m n) 'False 'False 'True----- | Maximum between two comparable types.------ @since 4.16.0.0-type Max :: k -> k -> k-type Max m n = OrdCond (Compare m n) n n m---- | Minimum between two comparable types.------ @since 4.16.0.0-type Min :: k -> k -> k-type Min m n = OrdCond (Compare m n) m m n----- | A case statement on 'Ordering'.------ @OrdCond c l e g@ is @l@ when @c ~ LT@, @e@ when @c ~ EQ@, and @g@ when--- @c ~ GT@.------ @since 4.16.0.0-type OrdCond :: Ordering -> k -> k -> k -> k-type family OrdCond o lt eq gt where-  OrdCond 'LT lt eq gt = lt-  OrdCond 'EQ lt eq gt = eq-  OrdCond 'GT lt eq gt = gt
− Data/Typeable.hs 
@@ -1,232 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Typeable--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ The 'Typeable' class reifies types to some extent by associating type--- representations to types. These type representations can be compared,--- and one can in turn define a type-safe cast operation. To this end,--- an unsafe cast is guarded by a test for type (representation)--- equivalence. The module "Data.Dynamic" uses Typeable for an--- implementation of dynamics. The module "Data.Data" uses Typeable--- and type-safe cast (but not dynamics) to support the \"Scrap your--- boilerplate\" style of generic programming.------ == Compatibility Notes------ Since GHC 8.2, GHC has supported type-indexed type representations.--- "Data.Typeable" provides type representations which are qualified over this--- index, providing an interface very similar to the "Typeable" notion seen in--- previous releases. For the type-indexed interface, see "Type.Reflection".------ Since GHC 7.10, all types automatically have 'Typeable' instances derived.--- This is in contrast to previous releases where 'Typeable' had to be--- explicitly derived using the @DeriveDataTypeable@ language extension.------ Since GHC 7.8, 'Typeable' is poly-kinded. The changes required for this might--- break some old programs involving 'Typeable'. More details on this, including--- how to fix your code, can be found on the--- <https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/poly-typeable PolyTypeable wiki page>-----------------------------------------------------------------------------------module Data.Typeable-    ( -- * The Typeable class-      Typeable-    , typeOf-    , typeRep--      -- * Propositional equality-    , (:~:)(Refl)-    , (:~~:)(HRefl)--      -- * Type-safe cast-    , cast-    , eqT-    , gcast                -- a generalisation of cast--      -- * Generalized casts for higher-order kinds-    , gcast1               -- :: ... => c (t a) -> Maybe (c (t' a))-    , gcast2               -- :: ... => c (t a b) -> Maybe (c (t' a b))--      -- * A canonical proxy type-    , Proxy (..)--      -- * Type representations-    , TypeRep-    , rnfTypeRep-    , showsTypeRep-    , mkFunTy--      -- * Observing type representations-    , funResultTy-    , splitTyConApp-    , typeRepArgs-    , typeRepTyCon-    , typeRepFingerprint--      -- * Type constructors-    , I.TyCon          -- abstract, instance of: Eq, Show, Typeable-                       -- For now don't export Module to avoid name clashes-    , I.tyConPackage-    , I.tyConModule-    , I.tyConName-    , I.rnfTyCon-    , I.tyConFingerprint--      -- * For backwards compatibility-    , typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7-      -- Jank-    , I.trLiftedRep-    ) where--import qualified Data.Typeable.Internal as I-import Data.Typeable.Internal (Typeable)-import Data.Type.Equality--import Data.Maybe-import Data.Proxy-import GHC.Fingerprint.Type-import GHC.Show-import GHC.Base---- | A quantified type representation.-type TypeRep = I.SomeTypeRep---- | Observe a type representation for the type of a value.-typeOf :: forall a. Typeable a => a -> TypeRep-typeOf _ = I.someTypeRep (Proxy :: Proxy a)---- | Takes a value of type @a@ and returns a concrete representation--- of that type.------ @since 4.7.0.0-typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep-typeRep = I.someTypeRep---- | Show a type representation-showsTypeRep :: TypeRep -> ShowS-showsTypeRep = shows---- | The type-safe cast operation-cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b-cast x-  | Just HRefl <- ta `I.eqTypeRep` tb = Just x-  | otherwise                         = Nothing-  where-    ta = I.typeRep :: I.TypeRep a-    tb = I.typeRep :: I.TypeRep b---- | Extract a witness of equality of two types------ @since 4.7.0.0-eqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)-eqT-  | Just HRefl <- ta `I.eqTypeRep` tb = Just Refl-  | otherwise                         = Nothing-  where-    ta = I.typeRep :: I.TypeRep a-    tb = I.typeRep :: I.TypeRep b---- | A flexible variation parameterised in a type constructor-gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b)-gcast x = fmap (\Refl -> x) (eqT :: Maybe (a :~: b))---- | Cast over @k1 -> k2@-gcast1 :: forall c t t' a. (Typeable t, Typeable t')-       => c (t a) -> Maybe (c (t' a))-gcast1 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))---- | Cast over @k1 -> k2 -> k3@-gcast2 :: forall c t t' a b. (Typeable t, Typeable t')-       => c (t a b) -> Maybe (c (t' a b))-gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))---- | Applies a type to a function type. Returns: @Just u@ if the first argument--- represents a function of type @t -> u@ and the second argument represents a--- function of type @t@. Otherwise, returns @Nothing@.-funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep-funResultTy (I.SomeTypeRep f) (I.SomeTypeRep x)-  | Just HRefl <- (I.typeRep :: I.TypeRep Type) `I.eqTypeRep` I.typeRepKind f-  , I.Fun arg res <- f-  , Just HRefl <- arg `I.eqTypeRep` x-  = Just (I.SomeTypeRep res)-  | otherwise = Nothing---- | Build a function type.-mkFunTy :: TypeRep -> TypeRep -> TypeRep-mkFunTy (I.SomeTypeRep arg) (I.SomeTypeRep res)-  | Just HRefl <- I.typeRepKind arg `I.eqTypeRep` liftedTy-  , Just HRefl <- I.typeRepKind res `I.eqTypeRep` liftedTy-  = I.SomeTypeRep (I.Fun arg res)-  | otherwise-  = error $ "mkFunTy: Attempted to construct function type from non-lifted "++-            "type: arg="++show arg++", res="++show res-  where liftedTy = I.typeRep :: I.TypeRep Type---- | Splits a type constructor application. Note that if the type constructor is--- polymorphic, this will not return the kinds that were used.-splitTyConApp :: TypeRep -> (TyCon, [TypeRep])-splitTyConApp (I.SomeTypeRep x) = I.splitApps x---- | Observe the argument types of a type representation-typeRepArgs :: TypeRep -> [TypeRep]-typeRepArgs ty = case splitTyConApp ty of (_, args) -> args---- | Observe the type constructor of a quantified type representation.-typeRepTyCon :: TypeRep -> TyCon-typeRepTyCon = I.someTypeRepTyCon---- | Takes a value of type @a@ and returns a concrete representation--- of that type.------ @since 4.7.0.0-typeRepFingerprint :: TypeRep -> Fingerprint-typeRepFingerprint = I.someTypeRepFingerprint---- | Force a 'TypeRep' to normal form.-rnfTypeRep :: TypeRep -> ()-rnfTypeRep = I.rnfSomeTypeRep----- Keeping backwards-compatibility-typeOf1 :: forall t (a :: Type). Typeable t => t a -> TypeRep-typeOf1 _ = I.someTypeRep (Proxy :: Proxy t)--typeOf2 :: forall t (a :: Type) (b :: Type). Typeable t => t a b -> TypeRep-typeOf2 _ = I.someTypeRep (Proxy :: Proxy t)--typeOf3 :: forall t (a :: Type) (b :: Type) (c :: Type).-           Typeable t => t a b c -> TypeRep-typeOf3 _ = I.someTypeRep (Proxy :: Proxy t)--typeOf4 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type).-           Typeable t => t a b c d -> TypeRep-typeOf4 _ = I.someTypeRep (Proxy :: Proxy t)--typeOf5 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type).-           Typeable t => t a b c d e -> TypeRep-typeOf5 _ = I.someTypeRep (Proxy :: Proxy t)--typeOf6 :: forall t (a :: Type) (b :: Type) (c :: Type)-                    (d :: Type) (e :: Type) (f :: Type).-           Typeable t => t a b c d e f -> TypeRep-typeOf6 _ = I.someTypeRep (Proxy :: Proxy t)--typeOf7 :: forall t (a :: Type) (b :: Type) (c :: Type)-                    (d :: Type) (e :: Type) (f :: Type) (g :: Type).-           Typeable t => t a b c d e f g -> TypeRep-typeOf7 _ = I.someTypeRep (Proxy :: Proxy t)
− Data/Typeable/Internal.hs 
@@ -1,1120 +0,0 @@-{-# LANGUAGE UnliftedFFITypes #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE LinearTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Typeable.Internal--- Copyright   :  (c) The University of Glasgow, CWI 2001--2011--- License     :  BSD-style (see the file libraries/base/LICENSE)------ The representations of the types TyCon and TypeRep, and the--- function mkTyCon which is used by derived instances of Typeable to--- construct a TyCon.-----------------------------------------------------------------------------------module Data.Typeable.Internal (-    -- * Typeable and kind polymorphism-    ---    -- #kind_instantiation--    -- * Miscellaneous-    Fingerprint(..),--    -- * Typeable class-    Typeable(..),-    withTypeable,--    -- * Module-    Module,  -- Abstract-    moduleName, modulePackage, rnfModule,--    -- * TyCon-    TyCon,   -- Abstract-    tyConPackage, tyConModule, tyConName, tyConKindArgs, tyConKindRep,-    tyConFingerprint,-    KindRep(.., KindRepTypeLit), TypeLitSort(..),-    rnfTyCon,--    -- * TypeRep-    TypeRep,-    pattern App, pattern Con, pattern Con', pattern Fun,-    typeRep,-    typeOf,-    typeRepTyCon,-    typeRepFingerprint,-    rnfTypeRep,-    eqTypeRep,-    typeRepKind,-    splitApps,--    -- * SomeTypeRep-    SomeTypeRep(..),-    someTypeRep,-    someTypeRepTyCon,-    someTypeRepFingerprint,-    rnfSomeTypeRep,--    -- * Construction-    -- | These are for internal use only-    mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,-    mkTyCon, mkTyCon#,-    typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep,--    -- * For internal use-    trLiftedRep-  ) where--import GHC.Prim ( FUN )-import GHC.Base-import qualified GHC.Arr as A-import GHC.Types ( TYPE, Multiplicity (Many) )-import Data.Type.Equality-import GHC.List ( splitAt, foldl', elem )-import GHC.Word-import GHC.Show-import GHC.TypeLits ( KnownChar, charVal', KnownSymbol, symbolVal', AppendSymbol )-import GHC.TypeNats ( KnownNat, Nat, natVal' )-import Unsafe.Coerce ( unsafeCoerce )--import GHC.Fingerprint.Type-import {-# SOURCE #-} GHC.Fingerprint-   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable-   -- Better to break the loop here, because we want non-SOURCE imports-   -- of Data.Typeable as much as possible so we can optimise the derived-   -- instances.--- import {-# SOURCE #-} Debug.Trace (trace)--#include "MachDeps.h"--{- *********************************************************************-*                                                                      *-                The TyCon type-*                                                                      *-********************************************************************* -}--modulePackage :: Module -> String-modulePackage (Module p _) = trNameString p--moduleName :: Module -> String-moduleName (Module _ m) = trNameString m--tyConPackage :: TyCon -> String-tyConPackage (TyCon _ _ m _ _ _) = modulePackage m--tyConModule :: TyCon -> String-tyConModule (TyCon _ _ m _ _ _) = moduleName m--tyConName :: TyCon -> String-tyConName (TyCon _ _ _ n _ _) = trNameString n--trNameString :: TrName -> String-trNameString (TrNameS s) = unpackCStringUtf8# s-trNameString (TrNameD s) = s--tyConFingerprint :: TyCon -> Fingerprint-tyConFingerprint (TyCon hi lo _ _ _ _)-  = Fingerprint (W64# hi) (W64# lo)--tyConKindArgs :: TyCon -> Int-tyConKindArgs (TyCon _ _ _ _ n _) = I# n--tyConKindRep :: TyCon -> KindRep-tyConKindRep (TyCon _ _ _ _ _ k) = k---- | 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--rnfKindRep :: KindRep -> ()-rnfKindRep (KindRepTyConApp tc args) = rnfTyCon tc `seq` rnfList rnfKindRep args-rnfKindRep (KindRepVar _)   = ()-rnfKindRep (KindRepApp a b) = rnfKindRep a `seq` rnfKindRep b-rnfKindRep (KindRepFun a b) = rnfKindRep a `seq` rnfKindRep b-rnfKindRep (KindRepTYPE rr) = rnfRuntimeRep rr-rnfKindRep (KindRepTypeLitS _ _) = ()-rnfKindRep (KindRepTypeLitD _ t) = rnfString t--rnfRuntimeRep :: RuntimeRep -> ()-rnfRuntimeRep (VecRep !_ !_) = ()-rnfRuntimeRep !_             = ()--rnfList :: (a -> ()) -> [a] -> ()-rnfList _     []     = ()-rnfList force (x:xs) = force x `seq` rnfList force xs--rnfString :: [Char] -> ()-rnfString = rnfList (`seq` ())--rnfTyCon :: TyCon -> ()-rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k---{- *********************************************************************-*                                                                      *-                The TypeRep type-*                                                                      *-********************************************************************* -}---- | A concrete representation of a (monomorphic) type.--- 'TypeRep' supports reasonably efficient equality.-type TypeRep :: k -> Type-data TypeRep a where-    -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2-    TrType :: TypeRep Type-    TrTyCon :: { -- See Note [TypeRep fingerprints]-                 trTyConFingerprint :: {-# UNPACK #-} !Fingerprint--                 -- The TypeRep represents the application of trTyCon-                 -- to the kind arguments trKindVars. So for-                 -- 'Just :: Bool -> Maybe Bool, the trTyCon will be-                 -- 'Just and the trKindVars will be [Bool].-               , trTyCon :: !TyCon-               , trKindVars :: [SomeTypeRep]-               , trTyConKind :: !(TypeRep k) }  -- See Note [Kind caching]-            -> TypeRep (a :: k)--    -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)-    -- are represented with @'TrFun' a b@, not @TrApp (TrApp funTyCon a) b@.-    TrApp   :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-               { -- See Note [TypeRep fingerprints]-                 trAppFingerprint :: {-# UNPACK #-} !Fingerprint--                 -- The TypeRep represents the application of trAppFun-                 -- to trAppArg. For Maybe Int, the trAppFun will be Maybe-                 -- and the trAppArg will be Int.-               , trAppFun :: !(TypeRep (a :: k1 -> k2))-               , trAppArg :: !(TypeRep (b :: k1))-               , trAppKind :: !(TypeRep k2) }   -- See Note [Kind caching]-            -> TypeRep (a b)--    -- | @TrFun fpr m a b@ represents a function type @a # m -> b@. We use this for-    -- the sake of efficiency as functions are quite ubiquitous.-    TrFun   :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                      (a :: TYPE r1) (b :: TYPE r2).-               { -- See Note [TypeRep fingerprints]-                 trFunFingerprint :: {-# UNPACK #-} !Fingerprint--                 -- The TypeRep represents a function from trFunArg to-                 -- trFunRes.-               , trFunMul :: !(TypeRep m)-               , trFunArg :: !(TypeRep a)-               , trFunRes :: !(TypeRep b) }-            -> TypeRep (FUN m a b)--{- Note [TypeRep fingerprints]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~-We store a Fingerprint of each TypeRep in its constructor. This allows-us to test whether two TypeReps are equal in constant time, rather than-having to walk their full structures.--}--{- Note [Kind caching]-   ~~~~~~~~~~~~~~~~~~~--We cache the kind of the TypeRep in each TrTyCon and TrApp constructor.-This is necessary to ensure that typeRepKind (which is used, at least, in-deserialization and dynApply) is cheap. There are two reasons for this:--1. Calculating the kind of a nest of type applications, such as--  F X Y Z W   (App (App (App (App F X) Y) Z) W)--is linear in the depth, which is already a bit pricy. In deserialization,-we build up such a nest from the inside out, so without caching, that ends-up taking quadratic time, and calculating the KindRep of the constructor,-F, a linear number of times. See #14254.--2. Calculating the kind of a type constructor, in instantiateTypeRep,-requires building (allocating) a TypeRep for the kind "from scratch".-This can get pricy. When combined with point (1), we can end up with-a large amount of extra allocation deserializing very deep nests.-See #14337.--It is quite possible to speed up deserialization by structuring that process-very carefully. Unfortunately, that doesn't help dynApply or anything else-that may use typeRepKind. Since caching the kind isn't terribly expensive, it-seems better to just do that and solve all the potential problems at once.--There are two things we need to be careful about when caching kinds.--Wrinkle 1:--We want to do it eagerly. Suppose we have--  tf :: TypeRep (f :: j -> k)-  ta :: TypeRep (a :: j)--Then the cached kind of App tf ta should be eagerly evaluated to k, rather-than being stored as a thunk that will strip the (j ->) off of j -> k if-and when it is forced.--Wrinkle 2:--We need to be able to represent TypeRep Type. This is a bit tricky because-typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the-typerep of the kind of Type, we will have a loop. One simple way to do this-is to make the cached kind fields lazy and allow TypeRep Type to be cyclical.--But we *do not* want TypeReps to have cyclical structure! Most importantly,-a cyclical structure cannot be stored in a compact region. Secondarily,-using :force in GHCi on a cyclical structure will lead to non-termination.--To avoid this trouble, we use a separate constructor for TypeRep Type.-mkTrApp is responsible for recognizing that TYPE is being applied to-'LiftedRep and produce trType; other functions must recognize that TrType-represents an application.--}---- Compare keys for equality---- | @since 2.01-instance Eq (TypeRep a) where-  _ == _  = True-  {-# INLINABLE (==) #-}--instance TestEquality TypeRep where-  a `testEquality` b-    | Just HRefl <- eqTypeRep a b-    = Just Refl-    | otherwise-    = Nothing-  {-# INLINEABLE testEquality #-}---- | @since 4.4.0.0-instance Ord (TypeRep a) where-  compare _ _ = EQ-  {-# INLINABLE compare #-}---- | A non-indexed type representation.-data SomeTypeRep where-    SomeTypeRep :: forall k (a :: k). !(TypeRep a) %1 -> SomeTypeRep--instance Eq SomeTypeRep where-  SomeTypeRep a == SomeTypeRep b =-      case a `eqTypeRep` b of-          Just _  -> True-          Nothing -> False--instance Ord SomeTypeRep where-  SomeTypeRep a `compare` SomeTypeRep b =-    typeRepFingerprint a `compare` typeRepFingerprint b---- | The function type constructor.------ For instance,------ @--- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char)--- @----pattern Fun :: forall k (fun :: k). ()-            => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                      (arg :: TYPE r1) (res :: TYPE r2).-               (k ~ Type, fun ~~ (arg -> res))-            => TypeRep arg-            -> TypeRep res-            -> TypeRep fun-pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res, trFunMul = (eqTypeRep trMany -> Just HRefl)}-  where Fun arg res = mkTrFun trMany arg res---- | Observe the 'Fingerprint' of a type representation------ @since 4.8.0.0-typeRepFingerprint :: TypeRep a -> Fingerprint-typeRepFingerprint TrType = fpTYPELiftedRep-typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr-typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr-typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr---- For compiler use-mkTrType :: TypeRep Type-mkTrType = TrType---- | Construct a representation for a type constructor--- applied at a monomorphic kind.------ Note that this is unsafe as it allows you to construct--- ill-kinded types.-mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a-mkTrCon tc kind_vars = TrTyCon-    { trTyConFingerprint = fpr-    , trTyCon = tc-    , trKindVars = kind_vars-    , trTyConKind = kind }-  where-    fpr_tc  = tyConFingerprint tc-    fpr_kvs = map someTypeRepFingerprint kind_vars-    fpr     = fingerprintFingerprints (fpr_tc:fpr_kvs)-    kind    = unsafeCoerceRep $ tyConKind tc kind_vars---- The fingerprint of Type. We don't store this in the TrType--- constructor, so we need to build it here.-fpTYPELiftedRep :: Fingerprint-fpTYPELiftedRep = fingerprintFingerprints-      [ tyConFingerprint tyConTYPE-      , fingerprintFingerprints-        [ tyConFingerprint tyCon'BoxedRep-        , tyConFingerprint tyCon'Lifted-        ]-      ]--- There is absolutely nothing to gain and everything to lose--- by inlining the worker. The wrapper should inline anyway.-{-# NOINLINE fpTYPELiftedRep #-}--trTYPE :: TypeRep TYPE-trTYPE = typeRep--trLiftedRep :: TypeRep ('BoxedRep 'Lifted)-trLiftedRep = typeRep--trMany :: TypeRep 'Many-trMany = typeRep---- | Construct a representation for a type application that is--- NOT a saturated arrow type. This is not checked!---- Note that this is known-key to the compiler, which uses it in desugar--- 'Typeable' evidence.-mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-           TypeRep (a :: k1 -> k2)-        -> TypeRep (b :: k1)-        -> TypeRep (a b)-mkTrApp a b -- See Note [Kind caching], Wrinkle 2-  | Just HRefl <- a `eqTypeRep` trTYPE-  , Just HRefl <- b `eqTypeRep` trLiftedRep-  = TrType--  | TrFun {trFunRes = res_kind} <- typeRepKind a-  = TrApp-    { trAppFingerprint = fpr-    , trAppFun = a-    , trAppArg = b-    , trAppKind = res_kind }--  | otherwise = error ("Ill-kinded type application: "-                           ++ show (typeRepKind a))-  where-    fpr_a = typeRepFingerprint a-    fpr_b = typeRepFingerprint b-    fpr   = fingerprintFingerprints [fpr_a, fpr_b]---- | Construct a representation for a type application that--- may be a saturated arrow type. This is renamed to mkTrApp in--- Type.Reflection.Unsafe-mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-                  TypeRep (a :: k1 -> k2)-               -> TypeRep (b :: k1)-               -> TypeRep (a b)-mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x})-               (y :: TypeRep y)-  | TrTyCon {trTyCon=con} <- p-  , con == funTyCon  -- cheap check first-  , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)-  , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)-  , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry-                  $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep-  = mkTrFun trMany x y-mkTrAppChecked a b = mkTrApp a b---- | A type application.------ For instance,------ @--- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int)--- @------ Note that this will also match a function type,------ @--- typeRep \@(Int# -> Char)---   ===--- App (App arrow (typeRep \@Int#)) (typeRep \@Char)--- @------ where @arrow :: TypeRep ((->) :: TYPE IntRep -> Type -> Type)@.----pattern App :: forall k2 (t :: k2). ()-            => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)-            => TypeRep a -> TypeRep b -> TypeRep t-pattern App f x <- (splitApp -> IsApp f x)-  where App f x = mkTrAppChecked f x--data AppOrCon (a :: k) where-    IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()-          => TypeRep f %1 -> TypeRep x %1 -> AppOrCon (f x)-    -- See Note [Con evidence]-    IsCon :: IsApplication a ~ "" => TyCon %1 -> [SomeTypeRep] %1 -> AppOrCon a--type family IsApplication (x :: k) :: Symbol where-  IsApplication (_ _) = "An error message about this unifying with \"\" "-     `AppendSymbol` "means that you tried to match a TypeRep with Con or "-     `AppendSymbol` "Con' when the represented type was known to be an "-     `AppendSymbol` "application."-  IsApplication _ = ""--splitApp :: forall k (a :: k). ()-         => TypeRep a-         -> AppOrCon a-splitApp TrType = IsApp trTYPE trLiftedRep-splitApp (TrApp {trAppFun = f, trAppArg = x}) = IsApp f x-splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = IsApp (mkTrApp arr a) b-  where arr = bareArrow rep-splitApp (TrTyCon{trTyCon = con, trKindVars = kinds})-  = case unsafeCoerce Refl :: IsApplication a :~: "" of-      Refl -> IsCon con kinds---- | Use a 'TypeRep' as 'Typeable' evidence.-withTypeable :: forall k (a :: k) rep (r :: TYPE rep). ()-             => TypeRep a -> (Typeable a => r) -> r-withTypeable rep k = unsafeCoerce k' rep-  where k' :: Gift a r-        k' = Gift k---- | A helper to satisfy the type checker in 'withTypeable'.-newtype Gift a (r :: TYPE rep) = Gift (Typeable a => r)---- | Pattern match on a type constructor-pattern Con :: forall k (a :: k). ()-            => IsApplication a ~ "" -- See Note [Con evidence]-            => TyCon -> TypeRep a-pattern Con con <- (splitApp -> IsCon con _)---- | Pattern match on a type constructor including its instantiated kind--- variables.------ For instance,------ @--- App (Con' proxyTyCon ks) intRep = typeRep @(Proxy \@Int)--- @------ will bring into scope,------ @--- proxyTyCon :: TyCon--- ks         == [someTypeRep @Type] :: [SomeTypeRep]--- intRep     == typeRep @Int--- @----pattern Con' :: forall k (a :: k). ()-             => IsApplication a ~ "" -- See Note [Con evidence]-             => TyCon -> [SomeTypeRep] -> TypeRep a-pattern Con' con ks <- (splitApp -> IsCon con ks)---- TODO: Remove Fun when #14253 is fixed-{-# COMPLETE Fun, App, Con  #-}-{-# COMPLETE Fun, App, Con' #-}--{- Note [Con evidence]-    ~~~~~~~~~~~~~~~~~~~--Matching TypeRep t on Con or Con' fakes up evidence that--  IsApplication t ~ "".--Why should anyone care about the value of strange internal type family?-Well, almost nobody cares about it, but the pattern checker does!-For example, suppose we have TypeRep (f x) and we want to get-TypeRep f and TypeRep x. There is no chance that the Con constructor-will match, because (f x) is not a constructor, but without the-IsApplication evidence, omitting it will lead to an incomplete pattern-warning. With the evidence, the pattern checker will see that-Con wouldn't typecheck, so everything works out as it should.--Why do we use Symbols? We would really like to use something like--  type family NotApplication (t :: k) :: Constraint where-    NotApplication (f a) = TypeError ...-    NotApplication _ = ()--Unfortunately, #11503 means that the pattern checker and type checker-will fail to actually reject the mistaken patterns. So we describe the-error in the result type. It's a horrible hack.--}------------------- Observation ------------------------- | Observe the type constructor of a quantified type representation.-someTypeRepTyCon :: SomeTypeRep -> TyCon-someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t---- | Observe the type constructor of a type representation-typeRepTyCon :: TypeRep a -> TyCon-typeRepTyCon TrType = tyConTYPE-typeRepTyCon (TrTyCon {trTyCon = tc}) = tc-typeRepTyCon (TrApp {trAppFun = a})   = typeRepTyCon a-typeRepTyCon (TrFun {})               = typeRepTyCon $ typeRep @(->)---- | Type equality------ @since 4.10-eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).-             TypeRep a -> TypeRep b -> Maybe (a :~~: b)-eqTypeRep a b-  | sameTypeRep a b = Just (unsafeCoerce HRefl)-  | otherwise       = Nothing--- We want GHC to inline eqTypeRep to get rid of the Maybe--- in the usual case that it is scrutinized immediately. We--- split eqTypeRep into a worker and wrapper because otherwise--- it's much larger than anything we'd want to inline.-{-# INLINABLE eqTypeRep #-}--sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2).-               TypeRep a -> TypeRep b -> Bool-sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b---------------------------------------------------------------------      Computing kinds--------------------------------------------------------------------- | Observe the kind of a type.-typeRepKind :: TypeRep (a :: k) -> TypeRep k-typeRepKind TrType = TrType-typeRepKind (TrTyCon {trTyConKind = kind}) = kind-typeRepKind (TrApp {trAppKind = kind}) = kind-typeRepKind (TrFun {}) = typeRep @Type--tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep-tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars =-    let kindVarsArr :: A.Array KindBndr SomeTypeRep-        kindVarsArr = A.listArray (0, I# (nKindVars# -# 1#)) kindVars-    in instantiateKindRep kindVarsArr kindRep--instantiateKindRep :: A.Array KindBndr SomeTypeRep -> KindRep -> SomeTypeRep-instantiateKindRep vars = go-  where-    go :: KindRep -> SomeTypeRep-    go (KindRepTyConApp tc args)-      = let n_kind_args = tyConKindArgs tc-            (kind_args, ty_args) = splitAt n_kind_args args-            -- First instantiate tycon kind arguments-            tycon_app = SomeTypeRep $ mkTrCon tc (map go kind_args)-            -- Then apply remaining type arguments-            applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep-            applyTy (SomeTypeRep acc) ty-              | SomeTypeRep ty' <- go ty-              = SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty'-        in foldl' applyTy tycon_app ty_args-    go (KindRepVar var)-      = vars A.! var-    go (KindRepApp f a)-      = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)-    go (KindRepFun a b)-      = SomeTypeRep $ mkTrFun trMany (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)-    go (KindRepTYPE (BoxedRep Lifted)) = SomeTypeRep TrType-    go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r-    go (KindRepTypeLitS sort s)-      = mkTypeLitFromString sort (unpackCStringUtf8# s)-    go (KindRepTypeLitD sort s)-      = mkTypeLitFromString sort s--    tYPE = kindedTypeRep @(RuntimeRep -> Type) @TYPE--unsafeCoerceRep :: SomeTypeRep -> TypeRep a-unsafeCoerceRep (SomeTypeRep r) = unsafeCoerce r--unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep-unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x--data SomeKindedTypeRep k where-    SomeKindedTypeRep :: forall k (a :: k). TypeRep a-                      %1 -> SomeKindedTypeRep k--kApp :: SomeKindedTypeRep (k -> k')-     -> SomeKindedTypeRep k-     -> SomeKindedTypeRep k'-kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) =-    SomeKindedTypeRep (mkTrApp f a)--kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k-kindedTypeRep = SomeKindedTypeRep (typeRep @a)--buildList :: forall k. Typeable k-          => [SomeKindedTypeRep k]-          -> SomeKindedTypeRep [k]-buildList = foldr cons nil-  where-    nil = kindedTypeRep @[k] @'[]-    cons x rest = SomeKindedTypeRep (typeRep @'(:)) `kApp` x `kApp` rest--runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep-runtimeRepTypeRep r =-    case r of-      BoxedRep Lifted -> SomeKindedTypeRep trLiftedRep-      BoxedRep v  -> kindedTypeRep @_ @'BoxedRep-                     `kApp` levityTypeRep v-      VecRep c e  -> kindedTypeRep @_ @'VecRep-                     `kApp` vecCountTypeRep c-                     `kApp` vecElemTypeRep e-      TupleRep rs -> kindedTypeRep @_ @'TupleRep-                     `kApp` buildList (map runtimeRepTypeRep rs)-      SumRep rs   -> kindedTypeRep @_ @'SumRep-                     `kApp` buildList (map runtimeRepTypeRep rs)-      IntRep      -> rep @'IntRep-      Int8Rep     -> rep @'Int8Rep-      Int16Rep    -> rep @'Int16Rep-      Int32Rep    -> rep @'Int32Rep-      Int64Rep    -> rep @'Int64Rep-      WordRep     -> rep @'WordRep-      Word8Rep    -> rep @'Word8Rep-      Word16Rep   -> rep @'Word16Rep-      Word32Rep   -> rep @'Word32Rep-      Word64Rep   -> rep @'Word64Rep-      AddrRep     -> rep @'AddrRep-      FloatRep    -> rep @'FloatRep-      DoubleRep   -> rep @'DoubleRep-  where-    rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep-    rep = kindedTypeRep @RuntimeRep @a--levityTypeRep :: Levity -> SomeKindedTypeRep Levity-levityTypeRep c =-    case c of-      Lifted   -> rep @'Lifted-      Unlifted -> rep @'Unlifted-  where-    rep :: forall (a :: Levity). Typeable a => SomeKindedTypeRep Levity-    rep = kindedTypeRep @Levity @a--vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount-vecCountTypeRep c =-    case c of-      Vec2  -> rep @'Vec2-      Vec4  -> rep @'Vec4-      Vec8  -> rep @'Vec8-      Vec16 -> rep @'Vec16-      Vec32 -> rep @'Vec32-      Vec64 -> rep @'Vec64-  where-    rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount-    rep = kindedTypeRep @VecCount @a--vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem-vecElemTypeRep e =-    case e of-      Int8ElemRep     -> rep @'Int8ElemRep-      Int16ElemRep    -> rep @'Int16ElemRep-      Int32ElemRep    -> rep @'Int32ElemRep-      Int64ElemRep    -> rep @'Int64ElemRep-      Word8ElemRep    -> rep @'Word8ElemRep-      Word16ElemRep   -> rep @'Word16ElemRep-      Word32ElemRep   -> rep @'Word32ElemRep-      Word64ElemRep   -> rep @'Word64ElemRep-      FloatElemRep    -> rep @'FloatElemRep-      DoubleElemRep   -> rep @'DoubleElemRep-  where-    rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem-    rep = kindedTypeRep @VecElem @a--bareArrow :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                    (a :: TYPE r1) (b :: TYPE r2). ()-          => TypeRep (FUN m a b)-          -> TypeRep (FUN m :: TYPE r1 -> TYPE r2 -> Type)-bareArrow (TrFun _ m a b) =-    mkTrCon funTyCon [SomeTypeRep m, SomeTypeRep rep1, SomeTypeRep rep2]-  where-    rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1-    rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2-bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"--data IsTYPE (a :: Type) where-    IsTYPE :: forall (r :: RuntimeRep). TypeRep r %1 -> IsTYPE (TYPE r)---- | Is a type of the form @TYPE rep@?-isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)-isTYPE TrType = Just (IsTYPE trLiftedRep)-isTYPE (TrApp {trAppFun=f, trAppArg=r})-  | Just HRefl <- f `eqTypeRep` typeRep @TYPE-  = Just (IsTYPE r)-isTYPE _ = Nothing--getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r-getRuntimeRep TrType = trLiftedRep-getRuntimeRep (TrApp {trAppArg=r}) = r-getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"----------------------------------------------------------------------      The Typeable class and friends--------------------------------------------------------------------- | The class 'Typeable' allows a concrete representation of a type to--- be calculated.-class Typeable (a :: k) where-  typeRep# :: TypeRep a--typeRep :: Typeable a => TypeRep a-typeRep = typeRep#--typeOf :: Typeable a => a -> TypeRep a-typeOf _ = typeRep---- | Takes a value of type @a@ and returns a concrete representation--- of that type.------ @since 4.7.0.0-someTypeRep :: forall proxy a. Typeable a => proxy a -> SomeTypeRep-someTypeRep _ = SomeTypeRep (typeRep :: TypeRep a)-{-# INLINE typeRep #-}--someTypeRepFingerprint :: SomeTypeRep -> Fingerprint-someTypeRepFingerprint (SomeTypeRep t) = typeRepFingerprint t------------------- Showing TypeReps ------------------------ This follows roughly the precedence structure described in Note [Precedence--- in types].-instance Show (TypeRep (a :: k)) where-    showsPrec = showTypeable---showTypeable :: Int -> TypeRep (a :: k) -> ShowS-showTypeable _ TrType = showChar '*'-showTypeable _ rep-  | isListTyCon tc, [ty] <- tys =-    showChar '[' . shows ty . showChar ']'--    -- Take care only to render saturated tuple tycon applications-    -- with tuple notation (#14341).-  | isTupleTyCon tc,-    Just _ <- TrType `eqTypeRep` typeRepKind rep =-    showChar '(' . showArgs (showChar ',') tys . showChar ')'-  where (tc, tys) = splitApps rep-showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []})-  = showTyCon tycon-showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args})-  = showParen (p > 9) $-    showTyCon tycon .-    showChar ' ' .-    showArgs (showChar ' ') args-showTypeable p (TrFun {trFunArg = x, trFunRes = r})-  = showParen (p > 8) $-    showsPrec 9 x . showString " -> " . showsPrec 8 r-showTypeable p (TrApp {trAppFun = f, trAppArg = x})-  = showParen (p > 9) $-    showsPrec 8 f .-    showChar ' ' .-    showsPrec 10 x---- | @since 4.10.0.0-instance Show SomeTypeRep where-  showsPrec p (SomeTypeRep ty) = showsPrec p ty--splitApps :: TypeRep a -> (TyCon, [SomeTypeRep])-splitApps = go []-  where-    go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep])-    go xs (TrTyCon {trTyCon = tc})-      = (tc, xs)-    go xs (TrApp {trAppFun = f, trAppArg = x})-      = go (SomeTypeRep x : xs) f-    go [] (TrFun {trFunArg = a, trFunRes = b, trFunMul = mul})-      | Just HRefl <- eqTypeRep trMany mul = (funTyCon, [SomeTypeRep a, SomeTypeRep b])-      | otherwise = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Only unrestricted functions are supported"-    go _  (TrFun {})-      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"-    go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])-    go _ TrType-      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2"---- This is incredibly shady! We don't really want to do this here; we--- should really have the compiler reveal the TYPE TyCon directly--- somehow. We need to construct this by hand because otherwise--- we end up with horrible and somewhat mysterious loops trying to calculate--- typeRep @TYPE. For the moment, we use the fact that we can get the proper--- name of the ghc-prim package from the TyCon of LiftedRep (which we can--- produce a TypeRep for without difficulty), and then just substitute in the--- appropriate module and constructor names.------ Prior to the introduction of BoxedRep, this was bad, but now it is--- even worse! We have to construct several different TyCons by hand--- so that we can build the fingerprint for TYPE ('BoxedRep 'LiftedRep).--- If we call `typeRep @('BoxedRep 'LiftedRep)` while trying to compute--- the fingerprint of `TYPE ('BoxedRep 'LiftedRep)`, we get a loop.------ The ticket to find a better way to deal with this is--- #14480.--tyConRuntimeRep :: TyCon-tyConRuntimeRep = mkTyCon ghcPrimPackage "GHC.Types" "RuntimeRep" 0-  (KindRepTYPE (BoxedRep Lifted))--tyConTYPE :: TyCon-tyConTYPE = mkTyCon ghcPrimPackage "GHC.Prim" "TYPE" 0-    (KindRepFun-      (KindRepTyConApp tyConRuntimeRep [])-      (KindRepTYPE (BoxedRep Lifted))-    )--tyConLevity :: TyCon-tyConLevity = mkTyCon ghcPrimPackage "GHC.Types" "Levity" 0-  (KindRepTYPE (BoxedRep Lifted))--tyCon'Lifted :: TyCon-tyCon'Lifted = mkTyCon ghcPrimPackage "GHC.Types" "'Lifted" 0-  (KindRepTyConApp tyConLevity [])--tyCon'BoxedRep :: TyCon-tyCon'BoxedRep = mkTyCon ghcPrimPackage "GHC.Types" "'BoxedRep" 0-  (KindRepFun (KindRepTyConApp tyConLevity []) (KindRepTyConApp tyConRuntimeRep []))--ghcPrimPackage :: String-ghcPrimPackage = tyConPackage (typeRepTyCon (typeRep @Bool))--funTyCon :: TyCon-funTyCon = typeRepTyCon (typeRep @(->))--isListTyCon :: TyCon -> Bool-isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])--isTupleTyCon :: TyCon -> Bool-isTupleTyCon tc-  | ('(':',':_) <- tyConName tc = True-  | otherwise                   = False---- This is only an approximation. We don't have the general--- character-classification machinery here, so we just do our best.--- This should work for promoted Haskell 98 data constructors and--- for TypeOperators type constructors that begin with ASCII--- characters, but it will miss Unicode operators.------ If we wanted to catch Unicode as well, we ought to consider moving--- GHC.Lexeme from ghc-boot-th to base. Then we could just say:------   startsVarSym symb || startsConSym symb------ But this is a fair deal of work just for one corner case, so I think I'll--- leave it like this unless someone shouts.-isOperatorTyCon :: TyCon -> Bool-isOperatorTyCon tc-  | symb : _ <- tyConName tc-  , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True-  | otherwise                           = False--showTyCon :: TyCon -> ShowS-showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon)--showArgs :: Show a => ShowS -> [a] -> ShowS-showArgs _   []     = id-showArgs _   [a]    = showsPrec 10 a-showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as---- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation------ @since 4.8.0.0-rnfTypeRep :: TypeRep a -> ()--- The TypeRep structure is almost entirely strict by definition. The--- fingerprinting and strict kind caching ensure that everything--- else is forced anyway. So we don't need to do anything special--- to reduce to normal form.-rnfTypeRep !_ = ()---- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@--- implementation------ @since 4.10.0.0-rnfSomeTypeRep :: SomeTypeRep -> ()-rnfSomeTypeRep (SomeTypeRep r) = rnfTypeRep r--{- *********************************************************-*                                                          *-*       TyCon/TypeRep definitions for type literals        *-*              (Symbol and Nat)                            *-*                                                          *-********************************************************* -}--pattern KindRepTypeLit :: TypeLitSort -> String -> KindRep-pattern KindRepTypeLit sort t <- (getKindRepTypeLit -> Just (sort, t))-  where-    KindRepTypeLit sort t = KindRepTypeLitD sort t--{-# COMPLETE KindRepTyConApp, KindRepVar, KindRepApp, KindRepFun,-             KindRepTYPE, KindRepTypeLit #-}--getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String)-getKindRepTypeLit (KindRepTypeLitS sort t) = Just (sort, unpackCStringUtf8# t)-getKindRepTypeLit (KindRepTypeLitD sort t) = Just (sort, t)-getKindRepTypeLit _                        = Nothing---- | Exquisitely unsafe.-mkTyCon# :: Addr#       -- ^ package name-         -> Addr#       -- ^ module name-         -> Addr#       -- ^ the name of the type constructor-         -> Int#        -- ^ number of kind variables-         -> KindRep     -- ^ kind representation-         -> TyCon       -- ^ A unique 'TyCon' object-mkTyCon# pkg modl name n_kinds kind_rep-  | Fingerprint (W64# hi) (W64# lo) <- fingerprint-  = TyCon hi lo mod (TrNameS name) n_kinds kind_rep-  where-    mod = Module (TrNameS pkg) (TrNameS modl)-    fingerprint :: Fingerprint-    fingerprint = mkTyConFingerprint (unpackCStringUtf8# pkg)-                                     (unpackCStringUtf8# modl)-                                     (unpackCStringUtf8# name)---- it is extremely important that this fingerprint computation--- remains in sync with that in GHC.Tc.Instance.Typeable to ensure that type--- equality is correct.---- | Exquisitely unsafe.-mkTyCon :: String       -- ^ package name-        -> String       -- ^ module name-        -> String       -- ^ the name of the type constructor-        -> Int         -- ^ number of kind variables-        -> KindRep     -- ^ kind representation-        -> TyCon        -- ^ A unique 'TyCon' object--- Used when the strings are dynamically allocated,--- eg from binary deserialisation-mkTyCon pkg modl name (I# n_kinds) kind_rep-  | Fingerprint (W64# hi) (W64# lo) <- fingerprint-  = TyCon hi lo mod (TrNameD name) n_kinds kind_rep-  where-    mod = Module (TrNameD pkg) (TrNameD modl)-    fingerprint :: Fingerprint-    fingerprint = mkTyConFingerprint pkg modl name---- This must match the computation done in GHC.Tc.Instance.Typeable.mkTyConRepTyConRHS.-mkTyConFingerprint :: String -- ^ package name-                   -> String -- ^ module name-                   -> String -- ^ tycon name-                   -> Fingerprint-mkTyConFingerprint pkg_name mod_name tycon_name =-        fingerprintFingerprints-        [ fingerprintString pkg_name-        , fingerprintString mod_name-        , fingerprintString tycon_name-        ]--mkTypeLitTyCon :: String -> TyCon -> TyCon-mkTypeLitTyCon name kind_tycon-  = mkTyCon "base" "GHC.TypeLits" name 0 kind-  where kind = KindRepTyConApp kind_tycon []---- | Used to make `'Typeable' instance for things of kind Nat-typeNatTypeRep :: forall a. KnownNat a => TypeRep a-typeNatTypeRep = typeLitTypeRep (show (natVal' (proxy# @a))) tcNat---- | Used to make `'Typeable' instance for things of kind Symbol-typeSymbolTypeRep :: forall a. KnownSymbol a => TypeRep a-typeSymbolTypeRep = typeLitTypeRep (show (symbolVal' (proxy# @a))) tcSymbol---- | Used to make `'Typeable' instance for things of kind Char-typeCharTypeRep :: forall a. KnownChar a => TypeRep a-typeCharTypeRep = typeLitTypeRep (show (charVal' (proxy# @a))) tcChar--mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep-mkTypeLitFromString TypeLitSymbol s =-    SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol)-mkTypeLitFromString TypeLitNat s =-    SomeTypeRep $ (typeLitTypeRep s tcNat :: TypeRep Nat)-mkTypeLitFromString TypeLitChar s =-    SomeTypeRep $ (typeLitTypeRep s tcChar :: TypeRep Char)--tcSymbol :: TyCon-tcSymbol = typeRepTyCon (typeRep @Symbol)--tcNat :: TyCon-tcNat = typeRepTyCon (typeRep @Nat)--tcChar :: TyCon-tcChar = typeRepTyCon (typeRep @Char)---- | An internal function, to make representations for type literals.-typeLitTypeRep :: forall k (a :: k). (Typeable k) =>-                  String -> TyCon -> TypeRep a-typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) []---- | For compiler use.-mkTrFun :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                  (a :: TYPE r1) (b :: TYPE r2).-           TypeRep m -> TypeRep a -> TypeRep b -> TypeRep ((FUN m a b) :: Type)-mkTrFun mul arg res = TrFun-    { trFunFingerprint = fpr-    , trFunMul = mul-    , trFunArg = arg-    , trFunRes = res }-  where fpr = fingerprintFingerprints [ typeRepFingerprint mul-                                      , typeRepFingerprint arg-                                      , typeRepFingerprint res]--{- $kind_instantiation--Consider a type like 'Data.Proxy.Proxy',--@-data Proxy :: forall k. k -> Type-@--One might think that one could decompose an instantiation of this type like-@Proxy Int@ into two applications,--@-'App' (App a b) c === typeRep @(Proxy Int)-@--where,--@-a = typeRep @Proxy-b = typeRep @Type-c = typeRep @Int-@--However, this isn't the case. Instead we can only decompose into an application-and a constructor,--@-'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int)-@--The reason for this is that 'Typeable' can only represent /kind-monomorphic/-types. That is, we must saturate enough of @Proxy@\'s arguments to-fully determine its kind. In the particular case of @Proxy@ this means we must-instantiate the kind variable @k@ such that no @forall@-quantified variables-remain.--While it is not possible to decompose the 'Con' above into an application, it is-possible to observe the kind variable instantiations of the constructor with the-'Con\'' pattern,--@-'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int)-@--Here @kinds@ will be @[typeRep \@Type]@.---}
− Data/Unique.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Unique--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ An abstract interface to a unique symbol generator.-----------------------------------------------------------------------------------module Data.Unique (-   -- * Unique objects-   Unique,-   newUnique,-   hashUnique- ) where--import System.IO.Unsafe (unsafePerformIO)--import GHC.Num-import Data.IORef---- $setup--- >>> import Prelude---- | An abstract unique object.  Objects of type 'Unique' may be--- compared for equality and ordering and hashed into 'Int'.------ >>> :{--- do x <- newUnique---    print (x == x)---    y <- newUnique---    print (x == y)--- :}--- True--- False-newtype Unique = Unique Integer deriving (Eq,Ord)--uniqSource :: IORef Integer-uniqSource = unsafePerformIO (newIORef 0)-{-# NOINLINE uniqSource #-}---- | Creates a new object of type 'Unique'.  The value returned will--- not compare equal to any other value of type 'Unique' returned by--- previous calls to 'newUnique'.  There is no limit on the number of--- times 'newUnique' may be called.-newUnique :: IO Unique-newUnique = do-  r <- atomicModifyIORef' uniqSource $ \x -> let z = x+1 in (z,z)-  return (Unique r)---- SDM (18/3/2010): changed from MVar to STM.  This fixes---  1. there was no async exception protection---  2. there was a space leak (now new value is strict)---  3. using atomicModifyIORef would be slightly quicker, but can---     suffer from adverse scheduling issues (see #3838)---  4. also, the STM version is faster.---- SDM (30/4/2012): changed to IORef using atomicModifyIORef.  Reasons:---  1. STM version could not be used inside unsafePerformIO, if it---     happened to be poked inside an STM transaction.---  2. IORef version can be used with unsafeIOToSTM inside STM,---     because if the transaction retries then we just get a new---     Unique.---  3. IORef version is very slightly faster.---- IGL (08/06/2013): changed to using atomicModifyIORef' instead.---  This feels a little safer, from the point of view of not leaking---  memory, but the resulting core is identical.---- | Hashes a 'Unique' into an 'Int'.  Two 'Unique's may hash to the--- same value, although in practice this is unlikely.  The 'Int'--- returned makes a good hash key.-hashUnique :: Unique -> Int-hashUnique (Unique i) = integerToInt i
− Data/Version.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Version--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification in ReadP)------ A general library for representation and manipulation of versions.------ Versioning schemes are many and varied, so the version--- representation provided by this library is intended to be a--- compromise between complete generality, where almost no common--- functionality could reasonably be provided, and fixing a particular--- versioning scheme, which would probably be too restrictive.------ So the approach taken here is to provide a representation which--- subsumes many of the versioning schemes commonly in use, and we--- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String'--- which will be appropriate for some applications, but not all.-----------------------------------------------------------------------------------module Data.Version (-        -- * The @Version@ type-        Version(..),-        -- * A concrete representation of @Version@-        showVersion, parseVersion,-        -- * Constructor function-        makeVersion-  ) where--import Data.Functor     ( Functor(..) )-import Control.Applicative ( Applicative(..) )-import Data.Bool        ( (&&) )-import Data.Char        ( isDigit, isAlphaNum )-import Data.Eq-import Data.Int         ( Int )-import Data.List        ( map, sort, concat, concatMap, intersperse, (++) )-import Data.Ord-import Data.String      ( String )-import GHC.Generics-import GHC.Read-import GHC.Show-import Text.ParserCombinators.ReadP-import Text.Read        ( read )--{- |-A 'Version' represents the version of a software entity.--An instance of 'Eq' is provided, which implements exact equality-modulo reordering of the tags in the 'versionTags' field.--An instance of 'Ord' is also provided, which gives lexicographic-ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2,-etc.).  This is expected to be sufficient for many uses, but note that-you may need to use a more specific ordering for your versioning-scheme.  For example, some versioning schemes may include pre-releases-which have tags @\"pre1\"@, @\"pre2\"@, and so on, and these would need to-be taken into account when determining ordering.  In some cases, date-ordering may be more appropriate, so the application would have to-look for @date@ tags in the 'versionTags' field and compare those.-The bottom line is, don't always assume that 'compare' and other 'Ord'-operations are the right thing for every 'Version'.--Similarly, concrete representations of versions may differ.  One-possible concrete representation is provided (see 'showVersion' and-'parseVersion'), but depending on the application a different concrete-representation may be more appropriate.--}-data Version =-  Version { versionBranch :: [Int],-                -- ^ The numeric branch for this version.  This reflects the-                -- fact that most software versions are tree-structured; there-                -- is a main trunk which is tagged with versions at various-                -- points (1,2,3...), and the first branch off the trunk after-                -- version 3 is 3.1, the second branch off the trunk after-                -- version 3 is 3.2, and so on.  The tree can be branched-                -- arbitrarily, just by adding more digits.-                ---                -- We represent the branch as a list of 'Int', so-                -- version 3.2.1 becomes [3,2,1].  Lexicographic ordering-                -- (i.e. the default instance of 'Ord' for @[Int]@) gives-                -- the natural ordering of branches.--           versionTags :: [String]  -- really a bag-                -- ^ A version can be tagged with an arbitrary list of strings.-                -- The interpretation of the list of tags is entirely dependent-                -- on the entity that this version applies to.-        }-  deriving ( Read    -- ^ @since 2.01-           , Show    -- ^ @since 2.01-           , Generic -- ^ @since 4.9.0.0-           )-{-# DEPRECATED versionTags "See GHC ticket #2496" #-}--- TODO. Remove all references to versionTags in GHC 8.0 release.---- | @since 2.01-instance Eq Version where-  v1 == v2  =  versionBranch v1 == versionBranch v2-                && sort (versionTags v1) == sort (versionTags v2)-                -- tags may be in any order---- | @since 2.01-instance Ord Version where-  v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2---- -------------------------------------------------------------------------------- A concrete representation of 'Version'---- | Provides one possible concrete representation for 'Version'.  For--- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags'--- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@.----showVersion :: Version -> String-showVersion (Version branch tags)-  = concat (intersperse "." (map show branch)) ++-     concatMap ('-':) tags---- | A parser for versions in the format produced by 'showVersion'.----parseVersion :: ReadP Version-parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.')-                  tags   <- many (char '-' *> munch1 isAlphaNum)-                  pure Version{versionBranch=branch, versionTags=tags}---- | Construct tag-less 'Version'------ @since 4.8.0.0-makeVersion :: [Int] -> Version-makeVersion b = Version b []
− Data/Version.hs-boot 
@@ -1,12 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Version-  ( Version-  , makeVersion-  ) where--import GHC.Base--data Version--makeVersion :: [Int] -> Version
− Data/Void.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDeriving #-}-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Copyright   :  (C) 2008-2014 Edward Kmett--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  portable------ A logically uninhabited data type, used to indicate that a given--- term should not exist.------ @since 4.8.0.0------------------------------------------------------------------------------module Data.Void-    ( Void-    , absurd-    , vacuous-    ) where--import Control.Exception-import Data.Data-import Data.Ix-import GHC.Generics-import Data.Semigroup (Semigroup(..), stimesIdempotent)---- $setup--- >>> import Prelude---- | Uninhabited data type------ @since 4.8.0.0-data Void deriving-  ( Eq      -- ^ @since 4.8.0.0-  , Data    -- ^ @since 4.8.0.0-  , Generic -- ^ @since 4.8.0.0-  , Ord     -- ^ @since 4.8.0.0-  , Read    -- ^ Reading a 'Void' value is always a parse error, considering-            -- 'Void' as a data type with no constructors.-            ---            -- @since 4.8.0.0-  , Show    -- ^ @since 4.8.0.0-  )---- | @since 4.8.0.0-instance Ix Void where-    range _     = []-    index _     = absurd-    inRange _   = absurd-    rangeSize _ = 0---- | @since 4.8.0.0-instance Exception Void---- | @since 4.9.0.0-instance Semigroup Void where-    a <> _ = a-    stimes = stimesIdempotent---- | Since 'Void' values logically don't exist, this witnesses the--- logical reasoning tool of \"ex falso quodlibet\".------ >>> let x :: Either Void Int; x = Right 5--- >>> :{--- case x of---     Right r -> r---     Left l  -> absurd l--- :}--- 5------ @since 4.8.0.0-absurd :: Void -> a-absurd a = case a of {}---- | If 'Void' is uninhabited then any 'Functor' that holds only--- values of type 'Void' is holding no values.--- It is implemented in terms of @fmap absurd@.------ @since 4.8.0.0-vacuous :: Functor f => f Void -> f a-vacuous = fmap absurd
− Data/Word.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Word--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Unsigned integer types.-----------------------------------------------------------------------------------module Data.Word-  (-        -- * Unsigned integral types--        Word,-        Word8, Word16, Word32, Word64,--        -- * byte swapping-        byteSwap16, byteSwap32, byteSwap64,--        -- * bit reversal--        bitReverse8, bitReverse16, bitReverse32, bitReverse64-        -- * Notes--        -- $notes-        ) where--import GHC.Word-import GHC.Read () -- Need the `Read` instance for types defined in `GHC.Word`.--{- $notes--* All arithmetic is performed modulo 2^n, where n is the number of-  bits in the type.  One non-obvious consequence of this is that 'Prelude.negate'-  should /not/ raise an error on negative arguments.--* For coercing between any two integer types, use-  'Prelude.fromIntegral', which is specialized for all the-  common cases so should be fast enough.  Coercing word types to and-  from integer types preserves representation, not sign.--* An unbounded size unsigned integer type is available with-  'Numeric.Natural.Natural'.--* The rules that hold for 'Prelude.Enum' instances over a bounded type-  such as 'Prelude.Int' (see the section of the Haskell report dealing-  with arithmetic sequences) also hold for the 'Prelude.Enum' instances-  over the various 'Word' types defined here.--* Right and left shifts by amounts greater than or equal to the width-  of the type result in a zero result.  This is contrary to the-  behaviour in C, which is undefined; a common interpretation is to-  truncate the shift count to the width of the type, for example @1 \<\<-  32 == 1@ in some C implementations.--}-
− Debug/Trace.hs 
@@ -1,331 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UnboxedTuples #-}---------------------------------------------------------------------------------- |--- Module      :  Debug.Trace--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Functions for tracing and monitoring execution.------ These can be useful for investigating bugs or performance problems.--- They should /not/ be used in production code.-----------------------------------------------------------------------------------module Debug.Trace (-        -- * Tracing-        -- $tracing-        trace,-        traceId,-        traceShow,-        traceShowId,-        traceStack,-        traceIO,-        traceM,-        traceShowM,-        putTraceMsg,--        -- * Eventlog tracing-        -- $eventlog_tracing-        traceEvent,-        traceEventIO,-        flushEventLog,--        -- * Execution phase markers-        -- $markers-        traceMarker,-        traceMarkerIO,-  ) where--import System.IO.Unsafe--import Foreign.C.String-import GHC.Base-import qualified GHC.Foreign-import GHC.IO.Encoding-import GHC.Ptr-import GHC.Show-import GHC.Stack-import Data.List (null, partition)---- $setup--- >>> import Prelude---- $tracing------ The 'trace', 'traceShow' and 'traceIO' functions print messages to an output--- stream. They are intended for \"printf debugging\", that is: tracing the flow--- of execution and printing interesting values.------ All these functions evaluate the message completely before printing--- it; so if the message is not fully defined, none of it will be--- printed.------ The usual output stream is 'System.IO.stderr'. For Windows GUI applications--- (that have no stderr) the output is directed to the Windows debug console.--- Some implementations of these functions may decorate the string that\'s--- output to indicate that you\'re tracing.---- | The 'traceIO' function outputs the trace message from the IO monad.--- This sequences the output with respect to other IO actions.------ @since 4.5.0.0-traceIO :: String -> IO ()-traceIO msg =-    withCString "%s\n" $ \cfmt -> do-     -- NB: debugBelch can't deal with null bytes, so filter them-     -- out so we don't accidentally truncate the message.  See #9395-     let (nulls, msg') = partition (=='\0') msg-     withCString msg' $ \cmsg ->-      debugBelch cfmt cmsg-     when (not (null nulls)) $-       withCString "WARNING: previous trace message had null bytes" $ \cmsg ->-         debugBelch cfmt cmsg---- don't use debugBelch() directly, because we cannot call varargs functions--- using the FFI.-foreign import ccall unsafe "HsBase.h debugBelch2"-   debugBelch :: CString -> CString -> IO ()---- |-putTraceMsg :: String -> IO ()-putTraceMsg = traceIO-{-# DEPRECATED putTraceMsg "Use 'Debug.Trace.traceIO'" #-} -- deprecated in 7.4---{-# NOINLINE trace #-}-{-|-The 'trace' function outputs the trace message given as its first argument,-before returning the second argument as its result.--For example, this returns the value of @f x@ and outputs the message to stderr.-Depending on your terminal (settings), they may or may not be mixed.-->>> let x = 123; f = show->>> trace ("calling f with x = " ++ show x) (f x)-calling f with x = 123-"123"--The 'trace' function should /only/ be used for debugging, or for monitoring-execution. The function is not referentially transparent: its type indicates-that it is a pure function but it has the side effect of outputting the-trace message.--}-trace :: String -> a -> a-trace string expr = unsafePerformIO $ do-    traceIO string-    return expr--{-|-Like 'trace' but returns the message instead of a third value.-->>> traceId "hello"-hello-"hello"--@since 4.7.0.0--}-traceId :: String -> String-traceId a = trace a a--{-|-Like 'trace', but uses 'show' on the argument to convert it to a 'String'.--This makes it convenient for printing the values of interesting variables or-expressions inside a function. For example here we print the value of the-variables @x@ and @y@:-->>> let f x y = traceShow (x,y) (x + y) in f (1+2) 5-(3,5)-8---}-traceShow :: Show a => a -> b -> b-traceShow = trace . show--{-|-Like 'traceShow' but returns the shown value instead of a third value.-->>> traceShowId (1+2+3, "hello" ++ "world")-(6,"helloworld")-(6,"helloworld")--@since 4.7.0.0--}-traceShowId :: Show a => a -> a-traceShowId a = trace (show a) a--{-|-Like 'trace' but returning unit in an arbitrary 'Applicative' context. Allows-for convenient use in do-notation.--Note that the application of '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-'Control.Monad.IO.Class.MonadIO', @'Control.Monad.IO.Class.liftIO' . 'traceIO'@-may be a better option.-->>> :{-do-    x <- Just 3-    traceM ("x: " ++ show x)-    y <- pure 12-    traceM ("y: " ++ show y)-    pure (x*2 + y)-:}-x: 3-y: 12-Just 18--@since 4.7.0.0--}-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 <- Just 3-    traceShowM x-    y <- pure 12-    traceShowM y-    pure (x*2 + y)-:}-3-12-Just 18--@since 4.7.0.0--}-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--- 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.------ @since 4.5.0.0-traceStack :: String -> a -> a-traceStack str expr = unsafePerformIO $ do-   traceIO str-   stack <- currentCallStack-   when (not (null stack)) $ traceIO (renderStack stack)-   return expr----- $eventlog_tracing------ Eventlog tracing is a performance profiling system. These functions emit--- extra events into the eventlog. In combination with eventlog profiling--- tools these functions can be used for monitoring execution and--- investigating performance problems.------ Currently only GHC provides eventlog profiling, see the GHC user guide for--- details on how to use it. These function exists for other Haskell--- implementations but no events are emitted. Note that the string message is--- always evaluated, whether or not profiling is available or enabled.--{-# NOINLINE traceEvent #-}--- | The 'traceEvent' function behaves like 'trace' with the difference that--- the message is emitted to the eventlog, if eventlog profiling is available--- and enabled at runtime.------ It is suitable for use in pure code. In an IO context use 'traceEventIO'--- instead.------ Note that when using GHC's SMP runtime, it is possible (but rare) to get--- duplicate events emitted if two CPUs simultaneously evaluate the same thunk--- that uses 'traceEvent'.------ @since 4.5.0.0-traceEvent :: String -> a -> a-traceEvent msg expr = unsafeDupablePerformIO $ do-    traceEventIO msg-    return expr---- | The 'traceEventIO' function emits a message to the eventlog, if eventlog--- profiling is available and enabled at runtime.------ Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to--- other IO actions.------ @since 4.5.0.0-traceEventIO :: String -> IO ()-traceEventIO msg =-  GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->-    case traceEvent# p s of s' -> (# s', () #)---- $markers------ When looking at a profile for the execution of a program we often want to--- be able to mark certain points or phases in the execution and see that--- visually in the profile.------ For example, a program might have several distinct phases with different--- performance or resource behaviour in each phase. To properly interpret the--- profile graph we really want to see when each phase starts and ends.------ Markers let us do this: we can annotate the program to emit a marker at--- an appropriate point during execution and then see that in a profile.------ Currently this feature is only supported in GHC by the eventlog tracing--- system, but in future it may also be supported by the heap profiling or--- other profiling tools. These function exists for other Haskell--- implementations but they have no effect. Note that the string message is--- always evaluated, whether or not profiling is available or enabled.--{-# NOINLINE traceMarker #-}--- | The 'traceMarker' function emits a marker to the eventlog, if eventlog--- profiling is available and enabled at runtime. The @String@ is the name of--- the marker. The name is just used in the profiling tools to help you keep--- clear which marker is which.------ This function is suitable for use in pure code. In an IO context use--- 'traceMarkerIO' instead.------ Note that when using GHC's SMP runtime, it is possible (but rare) to get--- duplicate events emitted if two CPUs simultaneously evaluate the same thunk--- that uses 'traceMarker'.------ @since 4.7.0.0-traceMarker :: String -> a -> a-traceMarker msg expr = unsafeDupablePerformIO $ do-    traceMarkerIO msg-    return expr---- | The 'traceMarkerIO' function emits a marker to the eventlog, if eventlog--- profiling is available and enabled at runtime.------ Compared to 'traceMarker', 'traceMarkerIO' sequences the event with respect to--- other IO actions.------ @since 4.7.0.0-traceMarkerIO :: String -> IO ()-traceMarkerIO msg =-  GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->-    case traceMarker# p s of s' -> (# s', () #)---- | Immediately flush the event log, if enabled.------ @since 4.15.0.0-flushEventLog :: IO ()-flushEventLog = c_flushEventLog nullPtr--foreign import ccall "flushEventLog" c_flushEventLog :: Ptr () -> IO ()
− Debug/Trace.hs-boot 
@@ -1,76 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UnboxedTuples #-}---- This boot file is necessary to allow GHC developers to--- use trace facilities in those (relatively few) modules that Debug.Trace--- itself depends on. It is also necessary to make DsMonad.pprRuntimeTrace--- trace injections work in those modules.---------------------------------------------------------------------------------- |--- Module      :  Debug.Trace--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Functions for tracing and monitoring execution.------ These can be useful for investigating bugs or performance problems.--- They should /not/ be used in production code.-----------------------------------------------------------------------------------module Debug.Trace (-        -- * Tracing-        -- $tracing-        trace,-        traceId,-        traceShow,-        traceShowId,-        traceStack,-        traceIO,-        traceM,-        traceShowM,--        -- * Eventlog tracing-        -- $eventlog_tracing-        traceEvent,-        traceEventIO,--        -- * Execution phase markers-        -- $markers-        traceMarker,-        traceMarkerIO,-  ) where--import GHC.Base-import GHC.Show--traceIO :: String -> IO ()--trace :: String -> a -> a--traceId :: String -> String--traceShow :: Show a => a -> b -> b--traceShowId :: Show a => a -> a--traceM :: Applicative f => String -> f ()--traceShowM :: (Show a, Applicative f) => a -> f ()--traceStack :: String -> a -> a--traceEvent :: String -> a -> a--traceEventIO :: String -> IO ()--traceMarker :: String -> a -> a--traceMarkerIO :: String -> IO ()
− Foreign.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ A collection of data types, classes, and functions for interfacing--- with another programming language.-----------------------------------------------------------------------------------module Foreign-        ( module Data.Bits-        , module Data.Int-        , module Data.Word-        , module Foreign.Ptr-        , module Foreign.ForeignPtr-        , module Foreign.StablePtr-        , module Foreign.Storable-        , module Foreign.Marshal-        ) where--import Data.Bits-import Data.Int-import Data.Word-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.StablePtr-import Foreign.Storable-import Foreign.Marshal-
− Foreign/C.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.C--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Bundles the C specific FFI library functionality-----------------------------------------------------------------------------------module Foreign.C-        ( module Foreign.C.Types-        , module Foreign.C.String-        , module Foreign.C.Error-        ) where--import Foreign.C.Types-import Foreign.C.String-import Foreign.C.Error-
− Foreign/C/Error.hs 
@@ -1,580 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.C.Error--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ C-specific Marshalling support: Handling of C \"errno\" error codes.-----------------------------------------------------------------------------------module Foreign.C.Error (--  -- * Haskell representations of @errno@ values--  Errno(..),--  -- ** Common @errno@ symbols-  -- | Different operating systems and\/or C libraries often support-  -- different values of @errno@.  This module defines the common values,-  -- but due to the open definition of 'Errno' users may add definitions-  -- which are not predefined.-  eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,-  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,-  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,-  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,-  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,-  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,-  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,-  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,-  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTSUP, eNOTTY, eNXIO,-  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,-  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,-  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,-  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,-  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV,--  -- ** 'Errno' functions-  isValidErrno,--  -- access to the current thread's "errno" value-  ---  getErrno,-  resetErrno,--  -- conversion of an "errno" value into IO error-  ---  errnoToIOError,--  -- throw current "errno" value-  ---  throwErrno,--  -- ** Guards for IO operations that may fail--  throwErrnoIf,-  throwErrnoIf_,-  throwErrnoIfRetry,-  throwErrnoIfRetry_,-  throwErrnoIfMinus1,-  throwErrnoIfMinus1_,-  throwErrnoIfMinus1Retry,-  throwErrnoIfMinus1Retry_,-  throwErrnoIfNull,-  throwErrnoIfNullRetry,--  throwErrnoIfRetryMayBlock,-  throwErrnoIfRetryMayBlock_,-  throwErrnoIfMinus1RetryMayBlock,-  throwErrnoIfMinus1RetryMayBlock_,-  throwErrnoIfNullRetryMayBlock,--  throwErrnoPath,-  throwErrnoPathIf,-  throwErrnoPathIf_,-  throwErrnoPathIfNull,-  throwErrnoPathIfMinus1,-  throwErrnoPathIfMinus1_,-) where----- this is were we get the CONST_XXX definitions from that configure--- calculated for us----#include "HsBaseConfig.h"--import Foreign.Ptr-import Foreign.C.Types-import Foreign.C.String-import Data.Functor            ( void )-import Data.Maybe--import GHC.IO-import GHC.IO.Exception-import GHC.IO.Handle.Types-import GHC.Num-import GHC.Base---- "errno" type--- ---------------- | Haskell representation for @errno@ values.--- The implementation is deliberately exposed, to allow users to add--- their own definitions of 'Errno' values.--newtype Errno = Errno CInt---- | @since 2.01-instance Eq Errno where-  errno1@(Errno no1) == errno2@(Errno no2)-    | isValidErrno errno1 && isValidErrno errno2 = no1 == no2-    | otherwise                                  = False---- common "errno" symbols----eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,-  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,-  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,-  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,-  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,-  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,-  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,-  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,-  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTSUP, eNOTTY, eNXIO,-  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,-  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,-  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,-  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,-  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV                    :: Errno------ the cCONST_XXX identifiers are cpp symbols whose value is computed by--- configure----eOK             = Errno 0-e2BIG           = Errno (CONST_E2BIG)-eACCES          = Errno (CONST_EACCES)-eADDRINUSE      = Errno (CONST_EADDRINUSE)-eADDRNOTAVAIL   = Errno (CONST_EADDRNOTAVAIL)-eADV            = Errno (CONST_EADV)-eAFNOSUPPORT    = Errno (CONST_EAFNOSUPPORT)-eAGAIN          = Errno (CONST_EAGAIN)-eALREADY        = Errno (CONST_EALREADY)-eBADF           = Errno (CONST_EBADF)-eBADMSG         = Errno (CONST_EBADMSG)-eBADRPC         = Errno (CONST_EBADRPC)-eBUSY           = Errno (CONST_EBUSY)-eCHILD          = Errno (CONST_ECHILD)-eCOMM           = Errno (CONST_ECOMM)-eCONNABORTED    = Errno (CONST_ECONNABORTED)-eCONNREFUSED    = Errno (CONST_ECONNREFUSED)-eCONNRESET      = Errno (CONST_ECONNRESET)-eDEADLK         = Errno (CONST_EDEADLK)-eDESTADDRREQ    = Errno (CONST_EDESTADDRREQ)-eDIRTY          = Errno (CONST_EDIRTY)-eDOM            = Errno (CONST_EDOM)-eDQUOT          = Errno (CONST_EDQUOT)-eEXIST          = Errno (CONST_EEXIST)-eFAULT          = Errno (CONST_EFAULT)-eFBIG           = Errno (CONST_EFBIG)-eFTYPE          = Errno (CONST_EFTYPE)-eHOSTDOWN       = Errno (CONST_EHOSTDOWN)-eHOSTUNREACH    = Errno (CONST_EHOSTUNREACH)-eIDRM           = Errno (CONST_EIDRM)-eILSEQ          = Errno (CONST_EILSEQ)-eINPROGRESS     = Errno (CONST_EINPROGRESS)-eINTR           = Errno (CONST_EINTR)-eINVAL          = Errno (CONST_EINVAL)-eIO             = Errno (CONST_EIO)-eISCONN         = Errno (CONST_EISCONN)-eISDIR          = Errno (CONST_EISDIR)-eLOOP           = Errno (CONST_ELOOP)-eMFILE          = Errno (CONST_EMFILE)-eMLINK          = Errno (CONST_EMLINK)-eMSGSIZE        = Errno (CONST_EMSGSIZE)-eMULTIHOP       = Errno (CONST_EMULTIHOP)-eNAMETOOLONG    = Errno (CONST_ENAMETOOLONG)-eNETDOWN        = Errno (CONST_ENETDOWN)-eNETRESET       = Errno (CONST_ENETRESET)-eNETUNREACH     = Errno (CONST_ENETUNREACH)-eNFILE          = Errno (CONST_ENFILE)-eNOBUFS         = Errno (CONST_ENOBUFS)-eNODATA         = Errno (CONST_ENODATA)-eNODEV          = Errno (CONST_ENODEV)-eNOENT          = Errno (CONST_ENOENT)-eNOEXEC         = Errno (CONST_ENOEXEC)-eNOLCK          = Errno (CONST_ENOLCK)-eNOLINK         = Errno (CONST_ENOLINK)-eNOMEM          = Errno (CONST_ENOMEM)-eNOMSG          = Errno (CONST_ENOMSG)-eNONET          = Errno (CONST_ENONET)-eNOPROTOOPT     = Errno (CONST_ENOPROTOOPT)-eNOSPC          = Errno (CONST_ENOSPC)-eNOSR           = Errno (CONST_ENOSR)-eNOSTR          = Errno (CONST_ENOSTR)-eNOSYS          = Errno (CONST_ENOSYS)-eNOTBLK         = Errno (CONST_ENOTBLK)-eNOTCONN        = Errno (CONST_ENOTCONN)-eNOTDIR         = Errno (CONST_ENOTDIR)-eNOTEMPTY       = Errno (CONST_ENOTEMPTY)-eNOTSOCK        = Errno (CONST_ENOTSOCK)-eNOTSUP         = Errno (CONST_ENOTSUP)--- ^ @since 4.7.0.0-eNOTTY          = Errno (CONST_ENOTTY)-eNXIO           = Errno (CONST_ENXIO)-eOPNOTSUPP      = Errno (CONST_EOPNOTSUPP)-ePERM           = Errno (CONST_EPERM)-ePFNOSUPPORT    = Errno (CONST_EPFNOSUPPORT)-ePIPE           = Errno (CONST_EPIPE)-ePROCLIM        = Errno (CONST_EPROCLIM)-ePROCUNAVAIL    = Errno (CONST_EPROCUNAVAIL)-ePROGMISMATCH   = Errno (CONST_EPROGMISMATCH)-ePROGUNAVAIL    = Errno (CONST_EPROGUNAVAIL)-ePROTO          = Errno (CONST_EPROTO)-ePROTONOSUPPORT = Errno (CONST_EPROTONOSUPPORT)-ePROTOTYPE      = Errno (CONST_EPROTOTYPE)-eRANGE          = Errno (CONST_ERANGE)-eREMCHG         = Errno (CONST_EREMCHG)-eREMOTE         = Errno (CONST_EREMOTE)-eROFS           = Errno (CONST_EROFS)-eRPCMISMATCH    = Errno (CONST_ERPCMISMATCH)-eRREMOTE        = Errno (CONST_ERREMOTE)-eSHUTDOWN       = Errno (CONST_ESHUTDOWN)-eSOCKTNOSUPPORT = Errno (CONST_ESOCKTNOSUPPORT)-eSPIPE          = Errno (CONST_ESPIPE)-eSRCH           = Errno (CONST_ESRCH)-eSRMNT          = Errno (CONST_ESRMNT)-eSTALE          = Errno (CONST_ESTALE)-eTIME           = Errno (CONST_ETIME)-eTIMEDOUT       = Errno (CONST_ETIMEDOUT)-eTOOMANYREFS    = Errno (CONST_ETOOMANYREFS)-eTXTBSY         = Errno (CONST_ETXTBSY)-eUSERS          = Errno (CONST_EUSERS)-eWOULDBLOCK     = Errno (CONST_EWOULDBLOCK)-eXDEV           = Errno (CONST_EXDEV)---- | Yield 'True' if the given 'Errno' value is valid on the system.--- This implies that the 'Eq' instance of 'Errno' is also system dependent--- as it is only defined for valid values of 'Errno'.----isValidErrno               :: Errno -> Bool------ the configure script sets all invalid "errno"s to -1----isValidErrno (Errno errno)  = errno /= -1----- access to the current thread's "errno" value--- ------------------------------------------------ | Get the current value of @errno@ in the current thread.------ On GHC, the runtime will ensure that any Haskell thread will only see "its own"--- @errno@, by saving and restoring the value when Haskell threads are scheduled--- across OS threads.-getErrno :: IO Errno---- We must call a C function to get the value of errno in general.  On--- threaded systems, errno is hidden behind a C macro so that each OS--- thread gets its own copy (`saved_errno`, which `rts/Schedule.c` restores--- back into the thread-local `errno` when a Haskell thread is rescheduled).-getErrno = do e <- get_errno; return (Errno e)-foreign import ccall unsafe "HsBase.h __hscore_get_errno" get_errno :: IO CInt---- | Reset the current thread\'s @errno@ value to 'eOK'.----resetErrno :: IO ()---- Again, setting errno has to be done via a C function.-resetErrno = set_errno 0-foreign import ccall unsafe "HsBase.h __hscore_set_errno" set_errno :: CInt -> IO ()---- throw current "errno" value--- ------------------------------- | Throw an 'IOError' corresponding to the current value of 'getErrno'.----throwErrno     :: String        -- ^ textual description of the error location-               -> IO a-throwErrno loc  =-  do-    errno <- getErrno-    ioError (errnoToIOError loc errno Nothing Nothing)----- guards for IO operations that may fail--- ------------------------------------------ | Throw an 'IOError' corresponding to the current value of 'getErrno'--- if the result value of the 'IO' action meets the given predicate.----throwErrnoIf    :: (a -> Bool)  -- ^ predicate to apply to the result value-                                -- of the 'IO' operation-                -> String       -- ^ textual description of the location-                -> IO a         -- ^ the 'IO' operation to be executed-                -> IO a-throwErrnoIf pred loc f  =-  do-    res <- f-    if pred res then throwErrno loc else return res---- | as 'throwErrnoIf', but discards the result of the 'IO' action after--- error handling.----throwErrnoIf_   :: (a -> Bool) -> String -> IO a -> IO ()-throwErrnoIf_ pred loc f  = void $ throwErrnoIf pred loc f---- | as 'throwErrnoIf', but retry the 'IO' action when it yields the--- error code 'eINTR' - this amounts to the standard retry loop for--- interrupted POSIX system calls.----throwErrnoIfRetry            :: (a -> Bool) -> String -> IO a -> IO a-throwErrnoIfRetry pred loc f  =-  do-    res <- f-    if pred res-      then do-        err <- getErrno-        if err == eINTR-          then throwErrnoIfRetry pred loc f-          else throwErrno loc-      else return res---- | as 'throwErrnoIfRetry', but additionally if the operation--- yields the error code 'eAGAIN' or 'eWOULDBLOCK', an alternative--- action is executed before retrying.----throwErrnoIfRetryMayBlock-                :: (a -> Bool)  -- ^ predicate to apply to the result value-                                -- of the 'IO' operation-                -> String       -- ^ textual description of the location-                -> IO a         -- ^ the 'IO' operation to be executed-                -> IO b         -- ^ action to execute before retrying if-                                -- an immediate retry would block-                -> IO a-throwErrnoIfRetryMayBlock pred loc f on_block  =-  do-    res <- f-    if pred res-      then do-        err <- getErrno-        if err == eINTR-          then throwErrnoIfRetryMayBlock pred loc f on_block-          else if err == eWOULDBLOCK || err == eAGAIN-                 then do _ <- on_block-                         throwErrnoIfRetryMayBlock pred loc f on_block-                 else throwErrno loc-      else return res---- | as 'throwErrnoIfRetry', but discards the result.----throwErrnoIfRetry_            :: (a -> Bool) -> String -> IO a -> IO ()-throwErrnoIfRetry_ pred loc f  = void $ throwErrnoIfRetry pred loc f---- | as 'throwErrnoIfRetryMayBlock', but discards the result.----throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()-throwErrnoIfRetryMayBlock_ pred loc f on_block-  = void $ throwErrnoIfRetryMayBlock pred loc f on_block---- | Throw an 'IOError' corresponding to the current value of 'getErrno'--- if the 'IO' action returns a result of @-1@.----throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a-throwErrnoIfMinus1  = throwErrnoIf (== -1)---- | as 'throwErrnoIfMinus1', but discards the result.----throwErrnoIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO ()-throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)---- | Throw an 'IOError' corresponding to the current value of 'getErrno'--- if the 'IO' action returns a result of @-1@, but retries in case of--- an interrupted operation.----throwErrnoIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a-throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)---- | as 'throwErrnoIfMinus1', but discards the result.----throwErrnoIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO ()-throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)---- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.----throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a)-                                => String -> IO a -> IO b -> IO a-throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)---- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.----throwErrnoIfMinus1RetryMayBlock_ :: (Eq a, Num a)-                                 => String -> IO a -> IO b -> IO ()-throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)---- | Throw an 'IOError' corresponding to the current value of 'getErrno'--- if the 'IO' action returns 'nullPtr'.----throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)-throwErrnoIfNull  = throwErrnoIf (== nullPtr)---- | Throw an 'IOError' corresponding to the current value of 'getErrno'--- if the 'IO' action returns 'nullPtr',--- but retry in case of an interrupted operation.----throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)-throwErrnoIfNullRetry  = throwErrnoIfRetry (== nullPtr)---- | as 'throwErrnoIfNullRetry', but checks for operations that would block.----throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)-throwErrnoIfNullRetryMayBlock  = throwErrnoIfRetryMayBlock (== nullPtr)---- | as 'throwErrno', but exceptions include the given path when appropriate.----throwErrnoPath :: String -> FilePath -> IO a-throwErrnoPath loc path =-  do-    errno <- getErrno-    ioError (errnoToIOError loc errno Nothing (Just path))---- | as 'throwErrnoIf', but exceptions include the given path when---   appropriate.----throwErrnoPathIf :: (a -> Bool) -> String -> FilePath -> IO a -> IO a-throwErrnoPathIf pred loc path f =-  do-    res <- f-    if pred res then throwErrnoPath loc path else return res---- | as 'throwErrnoIf_', but exceptions include the given path when---   appropriate.----throwErrnoPathIf_ :: (a -> Bool) -> String -> FilePath -> IO a -> IO ()-throwErrnoPathIf_ pred loc path f  = void $ throwErrnoPathIf pred loc path f---- | as 'throwErrnoIfNull', but exceptions include the given path when---   appropriate.----throwErrnoPathIfNull :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a)-throwErrnoPathIfNull  = throwErrnoPathIf (== nullPtr)---- | as 'throwErrnoIfMinus1', but exceptions include the given path when---   appropriate.----throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> FilePath -> IO a -> IO a-throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)---- | as 'throwErrnoIfMinus1_', but exceptions include the given path when---   appropriate.----throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> FilePath -> IO a -> IO ()-throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)---- conversion of an "errno" value into IO error--- ------------------------------------------------ | Construct an 'IOError' based on the given 'Errno' value.--- The optional information can be used to improve the accuracy of--- error messages.----errnoToIOError  :: String       -- ^ the location where the error occurred-                -> Errno        -- ^ the error number-                -> Maybe Handle -- ^ optional handle associated with the error-                -> Maybe String -- ^ optional filename associated with the error-                -> IOError-errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do-    str <- strerror errno >>= peekCString-    return (IOError maybeHdl errType loc str (Just errno') maybeName)-    where-    Errno errno' = errno-    errType-        | errno == eOK             = OtherError-        | errno == e2BIG           = ResourceExhausted-        | errno == eACCES          = PermissionDenied-        | errno == eADDRINUSE      = ResourceBusy-        | errno == eADDRNOTAVAIL   = UnsupportedOperation-        | errno == eADV            = OtherError-        | errno == eAFNOSUPPORT    = UnsupportedOperation-        | errno == eAGAIN          = ResourceExhausted-        | errno == eALREADY        = AlreadyExists-        | errno == eBADF           = InvalidArgument-        | errno == eBADMSG         = InappropriateType-        | errno == eBADRPC         = OtherError-        | errno == eBUSY           = ResourceBusy-        | errno == eCHILD          = NoSuchThing-        | errno == eCOMM           = ResourceVanished-        | errno == eCONNABORTED    = OtherError-        | errno == eCONNREFUSED    = NoSuchThing-        | errno == eCONNRESET      = ResourceVanished-        | errno == eDEADLK         = ResourceBusy-        | errno == eDESTADDRREQ    = InvalidArgument-        | errno == eDIRTY          = UnsatisfiedConstraints-        | errno == eDOM            = InvalidArgument-        | errno == eDQUOT          = PermissionDenied-        | errno == eEXIST          = AlreadyExists-        | errno == eFAULT          = OtherError-        | errno == eFBIG           = PermissionDenied-        | errno == eFTYPE          = InappropriateType-        | errno == eHOSTDOWN       = NoSuchThing-        | errno == eHOSTUNREACH    = NoSuchThing-        | errno == eIDRM           = ResourceVanished-        | errno == eILSEQ          = InvalidArgument-        | errno == eINPROGRESS     = AlreadyExists-        | errno == eINTR           = Interrupted-        | errno == eINVAL          = InvalidArgument-        | errno == eIO             = HardwareFault-        | errno == eISCONN         = AlreadyExists-        | errno == eISDIR          = InappropriateType-        | errno == eLOOP           = InvalidArgument-        | errno == eMFILE          = ResourceExhausted-        | errno == eMLINK          = ResourceExhausted-        | errno == eMSGSIZE        = ResourceExhausted-        | errno == eMULTIHOP       = UnsupportedOperation-        | errno == eNAMETOOLONG    = InvalidArgument-        | errno == eNETDOWN        = ResourceVanished-        | errno == eNETRESET       = ResourceVanished-        | errno == eNETUNREACH     = NoSuchThing-        | errno == eNFILE          = ResourceExhausted-        | errno == eNOBUFS         = ResourceExhausted-        | errno == eNODATA         = NoSuchThing-        | errno == eNODEV          = UnsupportedOperation-        | errno == eNOENT          = NoSuchThing-        | errno == eNOEXEC         = InvalidArgument-        | errno == eNOLCK          = ResourceExhausted-        | errno == eNOLINK         = ResourceVanished-        | errno == eNOMEM          = ResourceExhausted-        | errno == eNOMSG          = NoSuchThing-        | errno == eNONET          = NoSuchThing-        | errno == eNOPROTOOPT     = UnsupportedOperation-        | errno == eNOSPC          = ResourceExhausted-        | errno == eNOSR           = ResourceExhausted-        | errno == eNOSTR          = InvalidArgument-        | errno == eNOSYS          = UnsupportedOperation-        | errno == eNOTBLK         = InvalidArgument-        | errno == eNOTCONN        = InvalidArgument-        | errno == eNOTDIR         = InappropriateType-        | errno == eNOTEMPTY       = UnsatisfiedConstraints-        | errno == eNOTSOCK        = InvalidArgument-        | errno == eNOTTY          = IllegalOperation-        | errno == eNXIO           = NoSuchThing-        | errno == eOPNOTSUPP      = UnsupportedOperation-        | errno == ePERM           = PermissionDenied-        | errno == ePFNOSUPPORT    = UnsupportedOperation-        | errno == ePIPE           = ResourceVanished-        | errno == ePROCLIM        = PermissionDenied-        | errno == ePROCUNAVAIL    = UnsupportedOperation-        | errno == ePROGMISMATCH   = ProtocolError-        | errno == ePROGUNAVAIL    = UnsupportedOperation-        | errno == ePROTO          = ProtocolError-        | errno == ePROTONOSUPPORT = ProtocolError-        | errno == ePROTOTYPE      = ProtocolError-        | errno == eRANGE          = UnsupportedOperation-        | errno == eREMCHG         = ResourceVanished-        | errno == eREMOTE         = IllegalOperation-        | errno == eROFS           = PermissionDenied-        | errno == eRPCMISMATCH    = ProtocolError-        | errno == eRREMOTE        = IllegalOperation-        | errno == eSHUTDOWN       = IllegalOperation-        | errno == eSOCKTNOSUPPORT = UnsupportedOperation-        | errno == eSPIPE          = UnsupportedOperation-        | errno == eSRCH           = NoSuchThing-        | errno == eSRMNT          = UnsatisfiedConstraints-        | errno == eSTALE          = ResourceVanished-        | errno == eTIME           = TimeExpired-        | errno == eTIMEDOUT       = TimeExpired-        | errno == eTOOMANYREFS    = ResourceExhausted-        | errno == eTXTBSY         = ResourceBusy-        | errno == eUSERS          = ResourceExhausted-        | errno == eWOULDBLOCK     = OtherError-        | errno == eXDEV           = UnsupportedOperation-        | otherwise                = OtherError--foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)-
− Foreign/C/String.hs 
@@ -1,459 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.C.String--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Utilities for primitive marshalling of C strings.------ The marshalling converts each Haskell character, representing a Unicode--- code point, to one or more bytes in a manner that, by default, is--- determined by the current locale.  As a consequence, no guarantees--- can be made about the relative length of a Haskell string and its--- corresponding C string, and therefore all the marshalling routines--- include memory allocation.  The translation between Unicode and the--- encoding of the current locale may be lossy.-----------------------------------------------------------------------------------module Foreign.C.String (   -- representation of strings in C-  -- * C strings--  CString,-  CStringLen,--  -- ** Using a locale-dependent encoding--  -- | These functions are different from their @CAString@ counterparts-  -- in that they will use an encoding determined by the current locale,-  -- rather than always assuming ASCII.--  -- conversion of C strings into Haskell strings-  ---  peekCString,-  peekCStringLen,--  -- conversion of Haskell strings into C strings-  ---  newCString,-  newCStringLen,--  -- conversion of Haskell strings into C strings using temporary storage-  ---  withCString,-  withCStringLen,--  charIsRepresentable,--  -- ** Using 8-bit characters--  -- | These variants of the above functions are for use with C libraries-  -- that are ignorant of Unicode.  These functions should be used with-  -- care, as a loss of information can occur.--  castCharToCChar,-  castCCharToChar,--  castCharToCUChar,-  castCUCharToChar,-  castCharToCSChar,-  castCSCharToChar,--  peekCAString,-  peekCAStringLen,-  newCAString,-  newCAStringLen,-  withCAString,-  withCAStringLen,--  -- * C wide strings--  -- | These variants of the above functions are for use with C libraries-  -- that encode Unicode using the C @wchar_t@ type in a system-dependent-  -- way.  The only encodings supported are-  ---  -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or-  ---  -- * UTF-16 (as used on Windows systems).--  CWString,-  CWStringLen,--  peekCWString,-  peekCWStringLen,-  newCWString,-  newCWStringLen,-  withCWString,-  withCWStringLen,--  ) where--import Foreign.Marshal.Array-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable--import Data.Word--import GHC.Char-import GHC.List-import GHC.Real-import GHC.Num-import GHC.Base--import {-# SOURCE #-} GHC.IO.Encoding-import qualified GHC.Foreign as GHC---------------------------------------------------------------------------------- Strings---- representation of strings in C--- ---------------------------------- | A C string is a reference to an array of C characters terminated by NUL.-type CString    = Ptr CChar---- | A string with explicit length information in bytes instead of a--- terminating NUL (allowing NUL characters in the middle of the string).-type CStringLen = (Ptr CChar, Int)---- exported functions--- ------------------------ * the following routines apply the default conversion when converting the---   C-land character encoding into the Haskell-land character encoding---- | Marshal a NUL terminated C string into a Haskell string.----peekCString    :: CString -> IO String-peekCString s = getForeignEncoding >>= flip GHC.peekCString s---- | Marshal a C string with explicit length into a Haskell string.----peekCStringLen           :: CStringLen -> IO String-peekCStringLen s = getForeignEncoding >>= flip GHC.peekCStringLen s---- | Marshal a Haskell string into a NUL terminated C string.------ * the Haskell string may /not/ contain any NUL characters------ * new storage is allocated for the C string and must be---   explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCString :: String -> IO CString-newCString s = getForeignEncoding >>= flip GHC.newCString s---- | Marshal a Haskell string into a C string (ie, character array) with--- explicit length information.------ * new storage is allocated for the C string and must be---   explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCStringLen     :: String -> IO CStringLen-newCStringLen s = getForeignEncoding >>= flip GHC.newCStringLen s---- | Marshal a Haskell string into a NUL terminated C string using temporary--- storage.------ * the Haskell string may /not/ contain any NUL characters------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCString :: String -> (CString -> IO a) -> IO a-withCString s f = getForeignEncoding >>= \enc -> GHC.withCString enc s f---- | Marshal a Haskell string into a C string (ie, character array)--- in temporary storage, with explicit length information.------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCStringLen         :: String -> (CStringLen -> IO a) -> IO a-withCStringLen s f = getForeignEncoding >>= \enc -> GHC.withCStringLen enc s f---- -- | Determines whether a character can be accurately encoded in a 'CString'.--- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent.-charIsRepresentable :: Char -> IO Bool-charIsRepresentable c = getForeignEncoding >>= flip GHC.charIsRepresentable c---- single byte characters--- ----------------------------   ** NOTE: These routines don't handle conversions! **---- | Convert a C byte, representing a Latin-1 character, to the corresponding--- Haskell character.-castCCharToChar :: CChar -> Char-castCCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))---- | Convert a Haskell character to a C character.--- This function is only safe on the first 256 characters.-castCharToCChar :: Char -> CChar-castCharToCChar ch = fromIntegral (ord ch)---- | Convert a C @unsigned char@, representing a Latin-1 character, to--- the corresponding Haskell character.-castCUCharToChar :: CUChar -> Char-castCUCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))---- | Convert a Haskell character to a C @unsigned char@.--- This function is only safe on the first 256 characters.-castCharToCUChar :: Char -> CUChar-castCharToCUChar ch = fromIntegral (ord ch)---- | Convert a C @signed char@, representing a Latin-1 character, to the--- corresponding Haskell character.-castCSCharToChar :: CSChar -> Char-castCSCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))---- | Convert a Haskell character to a C @signed char@.--- This function is only safe on the first 256 characters.-castCharToCSChar :: Char -> CSChar-castCharToCSChar ch = fromIntegral (ord ch)---- | Marshal a NUL terminated C string into a Haskell string.----peekCAString    :: CString -> IO String-peekCAString cp = do-  l <- lengthArray0 nUL cp-  if l <= 0 then return "" else loop "" (l-1)-  where-    loop s i = do-        xval <- peekElemOff cp i-        let val = castCCharToChar xval-        val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)---- | Marshal a C string with explicit length into a Haskell string.----peekCAStringLen           :: CStringLen -> IO String-peekCAStringLen (cp, len)-  | len <= 0  = return "" -- being (too?) nice.-  | otherwise = loop [] (len-1)-  where-    loop acc i = do-         xval <- peekElemOff cp i-         let val = castCCharToChar xval-           -- blow away the coercion ASAP.-         if (val `seq` (i == 0))-          then return (val:acc)-          else loop (val:acc) (i-1)---- | Marshal a Haskell string into a NUL terminated C string.------ * the Haskell string may /not/ contain any NUL characters------ * new storage is allocated for the C string and must be---   explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCAString :: String -> IO CString-newCAString str = do-  ptr <- mallocArray0 (length str)-  let-        go [] n     = pokeElemOff ptr n nUL-        go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)-  go str 0-  return ptr---- | Marshal a Haskell string into a C string (ie, character array) with--- explicit length information.------ * new storage is allocated for the C string and must be---   explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCAStringLen     :: String -> IO CStringLen-newCAStringLen str = do-  ptr <- mallocArray0 len-  let-        go [] n     = n `seq` return () -- make it strict in n-        go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)-  go str 0-  return (ptr, len)-  where-    len = length str---- | Marshal a Haskell string into a NUL terminated C string using temporary--- storage.------ * the Haskell string may /not/ contain any NUL characters------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCAString :: String -> (CString -> IO a) -> IO a-withCAString str f =-  allocaArray0 (length str) $ \ptr ->-      let-        go [] n     = pokeElemOff ptr n nUL-        go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)-      in do-      go str 0-      f ptr---- | Marshal a Haskell string into a C string (ie, character array)--- in temporary storage, with explicit length information.------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCAStringLen         :: String -> (CStringLen -> IO a) -> IO a-withCAStringLen str f    =-  allocaArray len $ \ptr ->-      let-        go [] n     = n `seq` return () -- make it strict in n-        go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)-      in do-      go str 0-      f (ptr,len)-  where-    len = length str---- auxiliary definitions--- -------------------------- C's end of string character----nUL :: CChar-nUL  = 0---- allocate an array to hold the list and pair it with the number of elements-newArrayLen        :: Storable a => [a] -> IO (Ptr a, Int)-newArrayLen xs      = do-  a <- newArray xs-  return (a, length xs)---------------------------------------------------------------------------------- Wide strings---- representation of wide strings in C--- --------------------------------------- | A C wide string is a reference to an array of C wide characters--- terminated by NUL.-type CWString    = Ptr CWchar---- | A wide character string with explicit length information in 'CWchar's--- instead of a terminating NUL (allowing NUL characters in the middle--- of the string).-type CWStringLen = (Ptr CWchar, Int)---- | Marshal a NUL terminated C wide string into a Haskell string.----peekCWString    :: CWString -> IO String-peekCWString cp  = do-  cs <- peekArray0 wNUL cp-  return (cWcharsToChars cs)---- | Marshal a C wide string with explicit length into a Haskell string.----peekCWStringLen           :: CWStringLen -> IO String-peekCWStringLen (cp, len)  = do-  cs <- peekArray len cp-  return (cWcharsToChars cs)---- | Marshal a Haskell string into a NUL terminated C wide string.------ * the Haskell string may /not/ contain any NUL characters------ * new storage is allocated for the C wide string and must---   be explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCWString :: String -> IO CWString-newCWString  = newArray0 wNUL . charsToCWchars---- | Marshal a Haskell string into a C wide string (ie, wide character array)--- with explicit length information.------ * new storage is allocated for the C wide string and must---   be explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCWStringLen     :: String -> IO CWStringLen-newCWStringLen str  = newArrayLen (charsToCWchars str)---- | Marshal a Haskell string into a NUL terminated C wide string using--- temporary storage.------ * the Haskell string may /not/ contain any NUL characters------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCWString :: String -> (CWString -> IO a) -> IO a-withCWString  = withArray0 wNUL . charsToCWchars---- | Marshal a Haskell string into a C wide string (i.e. wide--- character array) in temporary storage, with explicit length--- information.------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a-withCWStringLen str f    =-  withArrayLen (charsToCWchars str) $ \ len ptr -> f (ptr, len)---- auxiliary definitions--- ------------------------wNUL :: CWchar-wNUL = 0--cWcharsToChars :: [CWchar] -> [Char]-charsToCWchars :: [Char] -> [CWchar]--#if defined(mingw32_HOST_OS)---- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding.---- coding errors generate Chars in the surrogate range-cWcharsToChars = map chr . fromUTF16 . map fromIntegral- where-  fromUTF16 (c1:c2:wcs)-    | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =-      ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs-  fromUTF16 (c:wcs) = c : fromUTF16 wcs-  fromUTF16 [] = []--charsToCWchars = foldr utf16Char [] . map ord- where-  utf16Char c wcs-    | c < 0x10000 = fromIntegral c : wcs-    | otherwise   = let c' = c - 0x10000 in-                    fromIntegral (c' `div` 0x400 + 0xd800) :-                    fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs--#else /* !mingw32_HOST_OS */--cWcharsToChars xs  = map castCWcharToChar xs-charsToCWchars xs  = map castCharToCWchar xs---- These conversions only make sense if __STDC_ISO_10646__ is defined--- (meaning that wchar_t is ISO 10646, aka Unicode)--castCWcharToChar :: CWchar -> Char-castCWcharToChar ch = chr (fromIntegral ch )--castCharToCWchar :: Char -> CWchar-castCharToCWchar ch = fromIntegral (ord ch)--#endif /* !mingw32_HOST_OS */-
− Foreign/C/Types.hs 
@@ -1,262 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}-{-# 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---------------------------------------------------------------------------------- |--- Module      :  Foreign.C.Types--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Mapping of C types to corresponding Haskell types.-----------------------------------------------------------------------------------module Foreign.C.Types-        ( -- * Representations of C types-          -- $ctypes--          -- ** #platform# Platform differences-          -- | This module contains platform specific information about types.-          -- __/As such, the types presented on this page reflect the/__-          -- __/platform on which the documentation was generated and may/__-          -- __/not coincide with the types on your platform./__--          -- ** Integral types-          -- | 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', 'Data.Typeable.Typeable',-          -- 'Storable', 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral'-          -- and 'Bits'.-          CChar(..),    CSChar(..),   CUChar(..)-        , CShort(..),   CUShort(..),  CInt(..),      CUInt(..)-        , CLong(..),    CULong(..)-        , CPtrdiff(..), CSize(..),    CWchar(..),    CSigAtomic(..)-        , CLLong(..),   CULLong(..), CBool(..)-        , CIntPtr(..),  CUIntPtr(..), CIntMax(..),   CUIntMax(..)--          -- ** Numeric types-          -- | These types are represented as @newtype@s of basic-          -- foreign types, and are instances of-          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',-          -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable' and-          -- 'Storable'.-        , CClock(..),   CTime(..),    CUSeconds(..), CSUSeconds(..)--        -- extracted from CTime, because we don't want this comment in-        -- the Haskell language reports:--        -- | To convert 'CTime' to 'Data.Time.UTCTime', use the following:-        ---        -- > \t -> posixSecondsToUTCTime (realToFrac t :: POSIXTime)-        ----          -- ** Floating types-          -- | 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', 'Data.Typeable.Typeable', 'Storable',-          -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',-          -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. That does mean-          -- that `CFloat`'s (respectively `CDouble`'s) instances of-          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num' and-          -- 'Prelude.Fractional' are as badly behaved as `Prelude.Float`'s-          -- (respectively `Prelude.Double`'s).-        , CFloat(..),   CDouble(..)-        -- XXX GHC doesn't support CLDouble yet-        -- , CLDouble(..)--          -- See Note [Exporting constructors of marshallable foreign types]-          -- in Foreign.Ptr for why the constructors for these newtypes are-          -- exported.--          -- ** Other types--          -- Instances of: Eq and Storable-        , CFile,        CFpos,     CJmpBuf-        ) where--import Foreign.Storable-import Data.Bits        ( Bits(..), FiniteBits(..) )-import Data.Int         ( Int8,  Int16,  Int32,  Int64  )-import Data.Word        ( Word8, Word16, Word32, Word64 )--import GHC.Base-import GHC.Float-import GHC.Enum-import GHC.Real-import GHC.Show-import GHC.Read-import GHC.Num-import GHC.Ix--#include "HsBaseConfig.h"-#include "CTypes.h"---- | Haskell type representing the C @char@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CChar,"char",HTYPE_CHAR)--- | Haskell type representing the C @signed char@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CSChar,"signed char",HTYPE_SIGNED_CHAR)--- | Haskell type representing the C @unsigned char@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CUChar,"unsigned char",HTYPE_UNSIGNED_CHAR)---- | Haskell type representing the C @short@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CShort,"short",HTYPE_SHORT)--- | Haskell type representing the C @unsigned short@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CUShort,"unsigned short",HTYPE_UNSIGNED_SHORT)---- | Haskell type representing the C @int@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CInt,"int",HTYPE_INT)--- | Haskell type representing the C @unsigned int@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CUInt,"unsigned int",HTYPE_UNSIGNED_INT)---- | Haskell type representing the C @long@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CLong,"long",HTYPE_LONG)--- | Haskell type representing the C @unsigned long@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CULong,"unsigned long",HTYPE_UNSIGNED_LONG)---- | Haskell type representing the C @long long@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CLLong,"long long",HTYPE_LONG_LONG)--- | Haskell type representing the C @unsigned long long@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CULLong,"unsigned long long",HTYPE_UNSIGNED_LONG_LONG)---- | Haskell type representing the C @bool@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/------ @since 4.10.0.0-INTEGRAL_TYPE(CBool,"bool",HTYPE_BOOL)---- | Haskell type representing the C @float@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-FLOATING_TYPE(CFloat,"float",HTYPE_FLOAT)--- | Haskell type representing the C @double@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-FLOATING_TYPE(CDouble,"double",HTYPE_DOUBLE)--- XXX GHC doesn't support CLDouble yet--{-# RULES-"realToFrac/a->CFloat"    realToFrac = \x -> CFloat   (realToFrac x)-"realToFrac/a->CDouble"   realToFrac = \x -> CDouble  (realToFrac x)--"realToFrac/CFloat->a"    realToFrac = \(CFloat   x) -> realToFrac x-"realToFrac/CDouble->a"   realToFrac = \(CDouble  x) -> realToFrac x- #-}---- GHC doesn't support CLDouble yet--- "realToFrac/a->CLDouble"  realToFrac = \x -> CLDouble (realToFrac x)--- "realToFrac/CLDouble->a"  realToFrac = \(CLDouble x) -> realToFrac x---- | Haskell type representing the C @ptrdiff_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CPtrdiff,"ptrdiff_t",HTYPE_PTRDIFF_T)--- | Haskell type representing the C @size_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CSize,"size_t",HTYPE_SIZE_T)--- | Haskell type representing the C @wchar_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CWchar,"wchar_t",HTYPE_WCHAR_T)--- | Haskell type representing the C @sig_atomic_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-INTEGRAL_TYPE(CSigAtomic,"sig_atomic_t",HTYPE_SIG_ATOMIC_T)---- | Haskell type representing the C @clock_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-ARITHMETIC_TYPE(CClock,"clock_t",HTYPE_CLOCK_T)--- | Haskell type representing the C @time_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-ARITHMETIC_TYPE(CTime,"time_t",HTYPE_TIME_T)--- | Haskell type representing the C @useconds_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/------ @since 4.4.0.0--ARITHMETIC_TYPE(CUSeconds,"useconds_t",HTYPE_USECONDS_T)--- | Haskell type representing the C @suseconds_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/------ @since 4.4.0.0-ARITHMETIC_TYPE(CSUSeconds,"suseconds_t",HTYPE_SUSECONDS_T)---- FIXME: Implement and provide instances for Eq and Storable--- | Haskell type representing the C @FILE@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-data CFile = CFile--- | Haskell type representing the C @fpos_t@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-data CFpos = CFpos--- | Haskell type representing the C @jmp_buf@ type.--- /(The concrete types of "Foreign.C.Types#platform" are platform-specific.)/-data CJmpBuf = CJmpBuf--INTEGRAL_TYPE(CIntPtr,"intptr_t",HTYPE_INTPTR_T)-INTEGRAL_TYPE(CUIntPtr,"uintptr_t",HTYPE_UINTPTR_T)-INTEGRAL_TYPE(CIntMax,"intmax_t",HTYPE_INTMAX_T)-INTEGRAL_TYPE(CUIntMax,"uintmax_t",HTYPE_UINTMAX_T)---- C99 types which are still missing include:--- wint_t, wctrans_t, wctype_t--{- $ctypes--These types are needed to accurately represent C function prototypes,-in order to access C library interfaces in Haskell.  The Haskell system-is not required to represent those types exactly as C does, but the-following guarantees are provided concerning a Haskell type @CT@-representing a C type @t@:--* If a C function prototype has @t@ as an argument or result type, the-  use of @CT@ in the corresponding position in a foreign declaration-  permits the Haskell program to access the full range of values encoded-  by the C type; and conversely, any Haskell value for @CT@ has a valid-  representation in C.--* @'sizeOf' ('Prelude.undefined' :: CT)@ will yield the same value as-  @sizeof (t)@ in C.--* @'alignment' ('Prelude.undefined' :: CT)@ matches the alignment-  constraint enforced by the C implementation for @t@.--* The members 'peek' and 'poke' of the 'Storable' class map all values-  of @CT@ to the corresponding value of @t@ and vice versa.--* When an instance of 'Prelude.Bounded' is defined for @CT@, the values-  of 'Prelude.minBound' and 'Prelude.maxBound' coincide with @t_MIN@-  and @t_MAX@ in C.--* When an instance of 'Prelude.Eq' or 'Prelude.Ord' is defined for @CT@,-  the predicates defined by the type class implement the same relation-  as the corresponding predicate in C on @t@.--* When an instance of 'Prelude.Num', 'Prelude.Read', 'Prelude.Integral',-  'Prelude.Fractional', 'Prelude.Floating', 'Prelude.RealFrac', or-  'Prelude.RealFloat' is defined for @CT@, the arithmetic operations-  defined by the type class implement the same function as the-  corresponding arithmetic operations (if available) in C on @t@.--* When an instance of 'Bits' is defined for @CT@, the bitwise operation-  defined by the type class implement the same function as the-  corresponding bitwise operation in C on @t@.---}-
− Foreign/Concurrent.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Concurrent--- Copyright   :  (c) The University of Glasgow 2003--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires concurrency)------ FFI datatypes and operations that use or require concurrency (GHC only).-----------------------------------------------------------------------------------module Foreign.Concurrent-  (-        -- * Concurrency-based 'ForeignPtr' operations--        -- | These functions generalize their namesakes in the portable-        -- "Foreign.ForeignPtr" module by allowing arbitrary 'IO' actions-        -- as finalizers.  These finalizers necessarily run in a separate-        -- thread, cf. /Destructors, Finalizers and Synchronization/,-        -- by Hans Boehm, /POPL/, 2003.--        newForeignPtr,-        addForeignPtrFinalizer,-  ) where--import GHC.IO         ( IO )-import GHC.Ptr        ( Ptr )-import GHC.ForeignPtr ( ForeignPtr )-import qualified GHC.ForeignPtr--newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)------ ^Turns a plain memory reference into a foreign object by--- associating a finalizer - given by the monadic operation - with the--- reference.  The storage manager will start the finalizer, in a--- separate thread, some time after the last reference to the--- 'ForeignPtr' is dropped.  There is no guarantee of promptness, and--- in fact there is no guarantee that the finalizer will eventually--- run at all.------ Note that references from a finalizer do not necessarily prevent--- another object from being finalized.  If A's finalizer refers to B--- (perhaps using 'Foreign.ForeignPtr.touchForeignPtr', then the only--- guarantee is that B's finalizer will never be started before A's.  If both--- A and B are unreachable, then both finalizers will start together.  See--- 'Foreign.ForeignPtr.touchForeignPtr' for more on finalizer ordering.----newForeignPtr = GHC.ForeignPtr.newConcForeignPtr--addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO ()--- ^This function adds a finalizer to the given 'ForeignPtr'.  The--- finalizer will run /before/ all other finalizers for the same--- object which have already been registered.------ This is a variant of 'Foreign.ForeignPtr.addForeignPtrFinalizer',--- where the finalizer is an arbitrary 'IO' action.  When it is--- invoked, the finalizer will run in a new thread.------ NB. Be very careful with these finalizers.  One common trap is that--- if a finalizer references another finalized value, it does not--- prevent that value from being finalized.  In particular, 'System.IO.Handle's--- are finalized objects, so a finalizer should not refer to a--- 'System.IO.Handle' (including 'System.IO.stdout', 'System.IO.stdin', or--- 'System.IO.stderr').----addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer-
− Foreign/ForeignPtr.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.ForeignPtr--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'ForeignPtr' type and operations.  This module is part of the--- Foreign Function Interface (FFI) and will usually be imported via--- the "Foreign" module.------ For non-portable support of Haskell finalizers, see the--- "Foreign.Concurrent" module.-----------------------------------------------------------------------------------module Foreign.ForeignPtr ( -        -- * Finalised data pointers-          ForeignPtr-        , FinalizerPtr-        , FinalizerEnvPtr--        -- ** Basic operations-        , newForeignPtr-        , newForeignPtr_-        , addForeignPtrFinalizer-        , newForeignPtrEnv-        , addForeignPtrFinalizerEnv-        , withForeignPtr-        , finalizeForeignPtr--        -- ** Low-level operations-        , touchForeignPtr-        , castForeignPtr-        , plusForeignPtr--        -- ** Allocating managed memory-        , mallocForeignPtr-        , mallocForeignPtrBytes-        , mallocForeignPtrArray-        , mallocForeignPtrArray0-    ) where--import Foreign.ForeignPtr.Imp-
− Foreign/ForeignPtr/Imp.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.ForeignPtr.Imp--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'ForeignPtr' type and operations.  This module is part of the--- Foreign Function Interface (FFI) and will usually be imported via--- the "Foreign" module.-----------------------------------------------------------------------------------module Foreign.ForeignPtr.Imp-        ( -        -- * Finalised data pointers-          ForeignPtr-        , FinalizerPtr-        , FinalizerEnvPtr--        -- ** Basic operations-        , newForeignPtr-        , newForeignPtr_-        , addForeignPtrFinalizer-        , newForeignPtrEnv-        , addForeignPtrFinalizerEnv-        , withForeignPtr-        , finalizeForeignPtr--        -- ** Low-level operations-        , unsafeForeignPtrToPtr-        , touchForeignPtr-        , castForeignPtr-        , plusForeignPtr--        -- ** Allocating managed memory-        , mallocForeignPtr-        , mallocForeignPtrBytes-        , mallocForeignPtrArray-        , mallocForeignPtrArray0-        ) -        where--import Foreign.Ptr-import Foreign.Storable ( Storable(sizeOf) )--import GHC.Base-import GHC.Num-import GHC.ForeignPtr--newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)--- ^Turns a plain memory reference into a foreign pointer, and--- associates a finalizer with the reference.  The finalizer will be--- executed after the last reference to the foreign object is dropped.--- There is no guarantee of promptness, however the finalizer will be--- executed before the program exits.-newForeignPtr finalizer p-  = do fObj <- newForeignPtr_ p-       addForeignPtrFinalizer finalizer fObj-       return fObj---- | This variant of 'newForeignPtr' adds a finalizer that expects an--- environment in addition to the finalized pointer.  The environment--- that will be passed to the finalizer is fixed by the second argument to--- 'newForeignPtrEnv'.-newForeignPtrEnv ::-    FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a)-newForeignPtrEnv finalizer env p-  = do fObj <- newForeignPtr_ p-       addForeignPtrFinalizerEnv finalizer env fObj-       return fObj---- | This function is similar to 'Foreign.Marshal.Array.mallocArray',--- but yields a memory area that has a finalizer attached that releases--- the memory area.  As with 'mallocForeignPtr', it is not guaranteed that--- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.-mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a)-mallocForeignPtrArray  = doMalloc undefined-  where-    doMalloc            :: Storable b => b -> Int -> IO (ForeignPtr b)-    doMalloc dummy size  = mallocForeignPtrBytes (size * sizeOf dummy)---- | This function is similar to 'Foreign.Marshal.Array.mallocArray0',--- but yields a memory area that has a finalizer attached that releases--- the memory area.  As with 'mallocForeignPtr', it is not guaranteed that--- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.-mallocForeignPtrArray0      :: Storable a => Int -> IO (ForeignPtr a)-mallocForeignPtrArray0 size  = mallocForeignPtrArray (size + 1)-
− Foreign/ForeignPtr/Safe.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.ForeignPtr.Safe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'ForeignPtr' type and operations.  This module is part of the--- Foreign Function Interface (FFI) and will usually be imported via--- the "Foreign" module.------ Safe API Only.-----------------------------------------------------------------------------------module Foreign.ForeignPtr.Safe {-# DEPRECATED "Safe is now the default, please use Foreign.ForeignPtr instead" #-} (-        -- * Finalised data pointers-          ForeignPtr-        , FinalizerPtr-        , FinalizerEnvPtr--        -- ** Basic operations-        , newForeignPtr-        , newForeignPtr_-        , addForeignPtrFinalizer-        , newForeignPtrEnv-        , addForeignPtrFinalizerEnv-        , withForeignPtr-        , finalizeForeignPtr--        -- ** Low-level operations-        , touchForeignPtr-        , castForeignPtr--        -- ** Allocating managed memory-        , mallocForeignPtr-        , mallocForeignPtrBytes-        , mallocForeignPtrArray-        , mallocForeignPtrArray0-    ) where--import Foreign.ForeignPtr.Imp-
− Foreign/ForeignPtr/Unsafe.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.ForeignPtr.Unsafe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'ForeignPtr' type and operations.  This module is part of the--- Foreign Function Interface (FFI) and will usually be imported via--- the "Foreign" module.------ Unsafe API Only.-----------------------------------------------------------------------------------module Foreign.ForeignPtr.Unsafe (-        -- ** Unsafe low-level operations-        unsafeForeignPtrToPtr,-    ) where--import Foreign.ForeignPtr.Imp-
− Foreign/Marshal.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal--- Copyright   :  (c) The FFI task force 2003--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Marshalling support-----------------------------------------------------------------------------------module Foreign.Marshal-        (-         -- | The module "Foreign.Marshal.Safe" re-exports the other modules in the-         -- @Foreign.Marshal@ hierarchy (except for @Foreign.Marshal.Unsafe@):-          module Foreign.Marshal.Alloc-        , module Foreign.Marshal.Array-        , module Foreign.Marshal.Error-        , module Foreign.Marshal.Pool-        , module Foreign.Marshal.Utils-        ) where--import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Marshal.Error-import Foreign.Marshal.Pool-import Foreign.Marshal.Utils-
− Foreign/Marshal/Alloc.hs 
@@ -1,237 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples,-             ScopedTypeVariables, BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Alloc--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ The module "Foreign.Marshal.Alloc" provides operations to allocate and--- deallocate blocks of raw memory (i.e., unstructured chunks of memory--- outside of the area maintained by the Haskell storage manager).  These--- memory blocks are commonly used to pass compound data structures to--- foreign functions or to provide space in which compound result values--- are obtained from foreign functions.--- --- If any of the allocation functions fails, an exception is thrown.--- In some cases, memory exhaustion may mean the process is terminated.--- If 'free' or 'reallocBytes' is applied to a memory area--- that has been allocated with 'alloca' or 'allocaBytes', the--- behaviour is undefined.  Any further access to memory areas allocated with--- 'alloca' or 'allocaBytes', after the computation that was passed to--- the allocation function has terminated, leads to undefined behaviour.  Any--- further access to the memory area referenced by a pointer passed to--- 'realloc', 'reallocBytes', or 'free' entails undefined--- behaviour.--- --- All storage allocated by functions that allocate based on a /size in bytes/--- must be sufficiently aligned for any of the basic foreign types--- that fits into the newly allocated storage. All storage allocated by--- functions that allocate based on a specific type must be sufficiently--- aligned for that type. Array allocation routines need to obey the same--- alignment constraints for each array element.-----------------------------------------------------------------------------------module Foreign.Marshal.Alloc (-  -- * Memory allocation-  -- ** Local allocation-  alloca,-  allocaBytes,-  allocaBytesAligned,--  -- ** Dynamic allocation-  malloc,-  mallocBytes,--  calloc,-  callocBytes,--  realloc,-  reallocBytes,--  free,-  finalizerFree-) where--import Data.Bits                ( Bits, (.&.) )-import Data.Maybe-import Foreign.C.Types          ( CSize(..) )-import Foreign.Storable         ( Storable(sizeOf,alignment) )-import Foreign.ForeignPtr       ( FinalizerPtr )-import GHC.IO.Exception-import GHC.Num-import GHC.Real-import GHC.Show-import GHC.Ptr-import GHC.Base---- exported functions--- ---------------------- |Allocate a block of memory that is sufficient to hold values of type--- @a@.  The size of the area allocated is determined by the 'sizeOf'--- method from the instance of 'Storable' for the appropriate type.------ The memory may be deallocated using 'free' or 'finalizerFree' when--- no longer required.----{-# INLINE malloc #-}-malloc :: forall a . Storable a => IO (Ptr a)-malloc  = mallocBytes (sizeOf (undefined :: a))---- |Like 'malloc' but memory is filled with bytes of value zero.----{-# INLINE calloc #-}-calloc :: forall a . Storable a => IO (Ptr a)-calloc = callocBytes (sizeOf (undefined :: a))---- |Allocate a block of memory of the given number of bytes.--- The block of memory is sufficiently aligned for any of the basic--- foreign types that fits into a memory block of the allocated size.------ The memory may be deallocated using 'free' or 'finalizerFree' when--- no longer required.----mallocBytes      :: Int -> IO (Ptr a)-mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))---- |Like 'mallocBytes', but memory is filled with bytes of value zero.----callocBytes :: Int -> IO (Ptr a)-callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size)---- |@'alloca' f@ executes the computation @f@, passing as argument--- a pointer to a temporarily allocated block of memory sufficient to--- hold values of type @a@.------ The memory is freed when @f@ terminates (either normally or via an--- exception), so the pointer passed to @f@ must /not/ be used after this.----{-# INLINE alloca #-}-alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b-alloca  =-  allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a))---- |@'allocaBytes' n f@ executes the computation @f@, passing as argument--- a pointer to a temporarily allocated block of memory of @n@ bytes.--- The block of memory is sufficiently aligned for any of the basic--- foreign types that fits into a memory block of the allocated size.------ The memory is freed when @f@ terminates (either normally or via an--- exception), so the pointer passed to @f@ must /not/ be used after this.----allocaBytes :: Int -> (Ptr a -> IO b) -> IO b-allocaBytes (I# size) action = IO $ \ s0 ->-     case newPinnedByteArray# size s0      of { (# s1, mbarr# #) ->-     case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->-     let addr = Ptr (byteArrayContents# barr#) in-     case action addr     of { IO action' ->-     keepAlive# barr# s2 action'-  }}}---- |@'allocaBytesAligned' size align f@ executes the computation @f@,--- passing as argument a pointer to a temporarily allocated block of memory--- of @size@ bytes and aligned to @align@ bytes. The value of @align@ must--- be a power of two.------ The memory is freed when @f@ terminates (either normally or via an--- exception), so the pointer passed to @f@ must /not/ be used after this.----allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b-allocaBytesAligned !_size !align !_action-    | not $ isPowerOfTwo align =-      ioError $-        IOError Nothing InvalidArgument-          "allocaBytesAligned"-          ("alignment (="++show align++") must be a power of two!")-          Nothing Nothing-  where-    isPowerOfTwo :: (Bits i, Integral i) => i -> Bool-    isPowerOfTwo x = x .&. (x-1) == 0-allocaBytesAligned !size !align !action =-    allocaBytesAlignedAndUnchecked size align action-{-# INLINABLE allocaBytesAligned #-}--allocaBytesAlignedAndUnchecked :: Int -> Int -> (Ptr a -> IO b) -> IO b-allocaBytesAlignedAndUnchecked (I# size) (I# align) action = IO $ \ s0 ->-     case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) ->-     case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr#  #) ->-     let addr = Ptr (byteArrayContents# barr#) in-     case action addr     of { IO action' ->-     keepAlive# barr# s2 action'-  }}}---- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'--- to the size needed to store values of type @b@.  The returned pointer--- may refer to an entirely different memory area, but will be suitably--- aligned to hold values of type @b@.  The contents of the referenced--- memory area will be the same as of the original pointer up to the--- minimum of the original size and the size of values of type @b@.------ If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like--- 'malloc'.----realloc :: forall a b . Storable b => Ptr a -> IO (Ptr b)-realloc ptr = failWhenNULL "realloc" (_realloc ptr size)-  where-    size = fromIntegral (sizeOf (undefined :: b))---- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'--- to the given size.  The returned pointer may refer to an entirely--- different memory area, but will be sufficiently aligned for any of the--- basic foreign types that fits into a memory block of the given size.--- The contents of the referenced memory area will be the same as of--- the original pointer up to the minimum of the original size and the--- given size.------ If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'--- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'--- behaves like 'free'.----reallocBytes          :: Ptr a -> Int -> IO (Ptr a)-reallocBytes ptr 0     = do free ptr; return nullPtr-reallocBytes ptr size  = -  failWhenNULL "realloc" (_realloc ptr (fromIntegral size))---- |Free a block of memory that was allocated with 'malloc',--- 'mallocBytes', 'realloc', 'reallocBytes', 'Foreign.Marshal.Utils.new'--- or any of the @new@/X/ functions in "Foreign.Marshal.Array" or--- "Foreign.C.String".----free :: Ptr a -> IO ()-free  = _free----- auxiliary routines--- ----------------------- asserts that the pointer returned from the action in the second argument is--- non-null----failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)-failWhenNULL name f = do-   addr <- f-   if addr == nullPtr-      then ioError (IOError Nothing ResourceExhausted name -                                        "out of memory" Nothing Nothing)-      else return addr---- basic C routines needed for memory allocation----foreign import ccall unsafe "stdlib.h malloc"  _malloc  ::          CSize -> IO (Ptr a)-foreign import ccall unsafe "stdlib.h calloc"  _calloc  :: CSize -> CSize -> IO (Ptr a)-foreign import ccall unsafe "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)-foreign import ccall unsafe "stdlib.h free"    _free    :: Ptr a -> IO ()---- | A pointer to a foreign function equivalent to 'free', which may be--- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage--- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.-foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a-
− Foreign/Marshal/Array.hs 
@@ -1,256 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Array--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Marshalling support: routines allocating, storing, and retrieving Haskell--- lists that are represented as arrays in the foreign language-----------------------------------------------------------------------------------module Foreign.Marshal.Array (-  -- * Marshalling arrays--  -- ** Allocation-  ---  mallocArray,-  mallocArray0,--  allocaArray,-  allocaArray0,--  reallocArray,-  reallocArray0,--  callocArray,-  callocArray0,--  -- ** Marshalling-  ---  peekArray,-  peekArray0,--  pokeArray,-  pokeArray0,--  -- ** Combined allocation and marshalling-  ---  newArray,-  newArray0,--  withArray,-  withArray0,--  withArrayLen,-  withArrayLen0,--  -- ** Copying--  -- | (argument order: destination, source)-  copyArray,-  moveArray,--  -- ** Finding the length-  ---  lengthArray0,--  -- ** Indexing-  ---  advancePtr,-) where--import Foreign.Ptr      (Ptr, plusPtr)-import Foreign.Storable (Storable(alignment,sizeOf,peekElemOff,pokeElemOff))-import Foreign.Marshal.Alloc (mallocBytes, callocBytes, allocaBytesAligned, reallocBytes)-import Foreign.Marshal.Utils (copyBytes, moveBytes)--import GHC.Num-import GHC.List-import GHC.Base---- allocation--- -------------- |Allocate storage for the given number of elements of a storable type--- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).----mallocArray :: forall a . Storable a => Int -> IO (Ptr a)-mallocArray  size = mallocBytes (size * sizeOf (undefined :: a))---- |Like 'mallocArray', but add an extra position to hold a special--- termination element.----mallocArray0      :: Storable a => Int -> IO (Ptr a)-mallocArray0 size  = mallocArray (size + 1)---- |Like 'mallocArray', but allocated memory is filled with bytes of value zero.----callocArray :: forall a . Storable a => Int -> IO (Ptr a)-callocArray size = callocBytes (size * sizeOf (undefined :: a))---- |Like 'callocArray0', but allocated memory is filled with bytes of value--- zero.----callocArray0 :: Storable a => Int -> IO (Ptr a)-callocArray0 size  = callocArray (size + 1)---- |Temporarily allocate space for the given number of elements--- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).----allocaArray :: forall a b . Storable a => Int -> (Ptr a -> IO b) -> IO b-allocaArray size = allocaBytesAligned (size * sizeOf (undefined :: a))-                                      (alignment (undefined :: a))---- |Like 'allocaArray', but add an extra position to hold a special--- termination element.----allocaArray0      :: Storable a => Int -> (Ptr a -> IO b) -> IO b-allocaArray0 size  = allocaArray (size + 1)-{-# INLINE allocaArray0 #-}-  -- needed to get allocaArray to inline into withCString, for unknown-  -- reasons --SDM 23/4/2010, see #4004 for benchmark---- |Adjust the size of an array----reallocArray :: forall a . Storable a => Ptr a -> Int -> IO (Ptr a)-reallocArray ptr size = reallocBytes ptr (size * sizeOf (undefined :: a))---- |Adjust the size of an array including an extra position for the end marker.----reallocArray0          :: Storable a => Ptr a -> Int -> IO (Ptr a)-reallocArray0 ptr size  = reallocArray ptr (size + 1)----- marshalling--- --------------- |Convert an array of given length into a Haskell list.  The implementation--- is tail-recursive and so uses constant stack space.----peekArray          :: Storable a => Int -> Ptr a -> IO [a]-peekArray size ptr | size <= 0 = return []-                 | otherwise = f (size-1) []-  where-    f 0 acc = do e <- peekElemOff ptr 0; return (e:acc)-    f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc)---- |Convert an array terminated by the given end marker into a Haskell list----peekArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO [a]-peekArray0 marker ptr  = do-  size <- lengthArray0 marker ptr-  peekArray size ptr---- |Write the list elements consecutive into memory----pokeArray :: Storable a => Ptr a -> [a] -> IO ()-pokeArray ptr vals0 = go vals0 0#-  where go [] _          = return ()-        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)---- |Write the list elements consecutive into memory and terminate them with the--- given marker element----pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()-pokeArray0 marker ptr vals0 = go vals0 0#-  where go [] n#         = pokeElemOff ptr (I# n#) marker-        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)---- combined allocation and marshalling--- --------------------------------------- |Write a list of storable elements into a newly allocated, consecutive--- sequence of storable values--- (like 'Foreign.Marshal.Utils.new', but for multiple elements).----newArray      :: Storable a => [a] -> IO (Ptr a)-newArray vals  = do-  ptr <- mallocArray (length vals)-  pokeArray ptr vals-  return ptr---- |Write a list of storable elements into a newly allocated, consecutive--- sequence of storable values, where the end is fixed by the given end marker----newArray0             :: Storable a => a -> [a] -> IO (Ptr a)-newArray0 marker vals  = do-  ptr <- mallocArray0 (length vals)-  pokeArray0 marker ptr vals-  return ptr---- |Temporarily store a list of storable values in memory--- (like 'Foreign.Marshal.Utils.with', but for multiple elements).----withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b-withArray vals = withArrayLen vals . const---- |Like 'withArray', but the action gets the number of values--- as an additional parameter----withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b-withArrayLen vals f  =-  allocaArray len $ \ptr -> do-      pokeArray ptr vals-      f len ptr-  where-    len = length vals---- |Like 'withArray', but a terminator indicates where the array ends----withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b-withArray0 marker vals = withArrayLen0 marker vals . const---- |Like 'withArrayLen', but a terminator indicates where the array ends----withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b-withArrayLen0 marker vals f  =-  allocaArray0 len $ \ptr -> do-      pokeArray0 marker ptr vals-      f len ptr-  where-    len = length vals---- copying (argument order: destination, source)--- ----------- |Copy the given number of elements from the second array (source) into the--- first array (destination); the copied areas may /not/ overlap----copyArray :: forall a . Storable a => Ptr a -> Ptr a -> Int -> IO ()-copyArray dest src size = copyBytes dest src (size * sizeOf (undefined :: a))---- |Copy the given number of elements from the second array (source) into the--- first array (destination); the copied areas /may/ overlap----moveArray :: forall a . Storable a => Ptr a -> Ptr a -> Int -> IO ()-moveArray  dest src size = moveBytes dest src (size * sizeOf (undefined :: a))----- finding the length--- ---------------------- |Return the number of elements in an array, excluding the terminator----lengthArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO Int-lengthArray0 marker ptr  = loop 0-  where-    loop i = do-        val <- peekElemOff ptr i-        if val == marker then return i else loop (i+1)----- indexing--- ------------ |Advance a pointer into an array by the given number of elements----advancePtr :: forall a . Storable a => Ptr a -> Int -> Ptr a-advancePtr ptr i = ptr `plusPtr` (i * sizeOf (undefined :: a))
− Foreign/Marshal/Error.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Error--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Routines for testing return values and raising a 'userError' exception--- in case of values indicating an error state.-----------------------------------------------------------------------------------module Foreign.Marshal.Error (-  throwIf,-  throwIf_,-  throwIfNeg,-  throwIfNeg_,-  throwIfNull,--  -- Discard return value-  ---  void-) where--import Foreign.Ptr--import GHC.Base-import GHC.Num-import GHC.IO.Exception---- exported functions--- ---------------------- |Execute an 'IO' action, throwing a 'userError' if the predicate yields--- 'True' when applied to the result returned by the 'IO' action.--- If no exception is raised, return the result of the computation.----throwIf :: (a -> Bool)  -- ^ error condition on the result of the 'IO' action-        -> (a -> String) -- ^ computes an error message from erroneous results-                        -- of the 'IO' action-        -> IO a         -- ^ the 'IO' action to be executed-        -> IO a-throwIf pred msgfct act  = -  do-    res <- act-    (if pred res then ioError . userError . msgfct else return) res---- |Like 'throwIf', but discarding the result----throwIf_                 :: (a -> Bool) -> (a -> String) -> IO a -> IO ()-throwIf_ pred msgfct act  = void $ throwIf pred msgfct act---- |Guards against negative result values----throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a-throwIfNeg  = throwIf (< 0)---- |Like 'throwIfNeg', but discarding the result----throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO ()-throwIfNeg_  = throwIf_ (< 0)---- |Guards against null pointers----throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)-throwIfNull  = throwIf (== nullPtr) . const---- |Discard the return value of an 'IO' action----void     :: IO a -> IO ()-void act  = act >> return ()-{-# DEPRECATED void "use 'Control.Monad.void' instead" #-} -- deprecated in 7.6
− Foreign/Marshal/Pool.hs 
@@ -1,187 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables #-}------------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Pool--- Copyright   :  (c) Sven Panne 2002-2004--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- Stability   :  provisional--- Portability :  portable------ This module contains support for pooled memory management. Under this scheme,--- (re-)allocations belong to a given pool, and everything in a pool is--- deallocated when the pool itself is deallocated. This is useful when--- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation--- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'--- and 'free' are too awkward.--------------------------------------------------------------------------------------module Foreign.Marshal.Pool (-   -- * Pool management-   Pool,-   newPool,-   freePool,-   withPool,--   -- * (Re-)Allocation within a pool-   pooledMalloc,-   pooledMallocBytes,--   pooledRealloc,-   pooledReallocBytes,--   pooledMallocArray,-   pooledMallocArray0,--   pooledReallocArray,-   pooledReallocArray0,--   -- * Combined allocation and marshalling-   pooledNew,-   pooledNewArray,-   pooledNewArray0-) where--import GHC.Base              ( Int, Monad(..), (.), liftM, not )-import GHC.Err               ( undefined )-import GHC.Exception         ( throw )-import GHC.IO                ( IO, mask, catchAny )-import GHC.IORef             ( IORef, newIORef, readIORef, writeIORef )-import GHC.List              ( elem, length )-import GHC.Num               ( Num(..) )--import Data.OldList          ( delete )-import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )-import Foreign.Marshal.Array ( pokeArray, pokeArray0 )-import Foreign.Marshal.Error ( throwIf )-import Foreign.Ptr           ( Ptr, castPtr )-import Foreign.Storable      ( Storable(sizeOf, poke) )-------------------------------------------------------------------------------------- To avoid non-H2010 stuff like existentially quantified data constructors, we--- simply use pointers to () below. Not very nice, but...---- | A memory pool.--newtype Pool = Pool (IORef [Ptr ()])---- | Allocate a fresh memory pool.--newPool :: IO Pool-newPool = liftM Pool (newIORef [])---- | Deallocate a memory pool and everything which has been allocated in the--- pool itself.--freePool :: Pool -> IO ()-freePool (Pool pool) = readIORef pool >>= freeAll-   where freeAll []     = return ()-         freeAll (p:ps) = free p >> freeAll ps---- | Execute an action with a fresh memory pool, which gets automatically--- deallocated (including its contents) after the action has finished.--withPool :: (Pool -> IO b) -> IO b-withPool act =   -- ATTENTION: cut-n-paste from Control.Exception below!-   mask (\restore -> do-      pool <- newPool-      val <- catchAny-                (restore (act pool))-                (\e -> do freePool pool; throw e)-      freePool pool-      return val)-------------------------------------------------------------------------------------- | Allocate space for storable type in the given pool. The size of the area--- allocated is determined by the 'sizeOf' method from the instance of--- 'Storable' for the appropriate type.--pooledMalloc :: forall a . Storable a => Pool -> IO (Ptr a)-pooledMalloc pool = pooledMallocBytes pool (sizeOf (undefined :: a))---- | Allocate the given number of bytes of storage in the pool.--pooledMallocBytes :: Pool -> Int -> IO (Ptr a)-pooledMallocBytes (Pool pool) size = do-   ptr <- mallocBytes size-   ptrs <- readIORef pool-   writeIORef pool (ptr:ptrs)-   return (castPtr ptr)---- | Adjust the storage area for an element in the pool to the given size of--- the required type.--pooledRealloc :: forall a . Storable a => Pool -> Ptr a -> IO (Ptr a)-pooledRealloc pool ptr = pooledReallocBytes pool ptr (sizeOf (undefined :: a))---- | Adjust the storage area for an element in the pool to the given size.--pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)-pooledReallocBytes (Pool pool) ptr size = do-   let cPtr = castPtr ptr-   _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)-   newPtr <- reallocBytes cPtr size-   ptrs <- readIORef pool-   writeIORef pool (newPtr : delete cPtr ptrs)-   return (castPtr newPtr)---- | Allocate storage for the given number of elements of a storable type in the--- pool.--pooledMallocArray :: forall a . Storable a => Pool -> Int -> IO (Ptr a)-pooledMallocArray pool size =-    pooledMallocBytes pool (size * sizeOf (undefined :: a))---- | Allocate storage for the given number of elements of a storable type in the--- pool, but leave room for an extra element to signal the end of the array.--pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)-pooledMallocArray0 pool size =-   pooledMallocArray pool (size + 1)---- | Adjust the size of an array in the given pool.--pooledReallocArray :: forall a . Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)-pooledReallocArray pool ptr size =-    pooledReallocBytes pool ptr (size * sizeOf (undefined :: a))---- | Adjust the size of an array with an end marker in the given pool.--pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)-pooledReallocArray0 pool ptr size =-   pooledReallocArray pool ptr (size + 1)-------------------------------------------------------------------------------------- | Allocate storage for a value in the given pool and marshal the value into--- this storage.--pooledNew :: Storable a => Pool -> a -> IO (Ptr a)-pooledNew pool val = do-   ptr <- pooledMalloc pool-   poke ptr val-   return ptr---- | Allocate consecutive storage for a list of values in the given pool and--- marshal these values into it.--pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)-pooledNewArray pool vals = do-   ptr <- pooledMallocArray pool (length vals)-   pokeArray ptr vals-   return ptr---- | Allocate consecutive storage for a list of values in the given pool and--- marshal these values into it, terminating the end with the given marker.--pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)-pooledNewArray0 pool marker vals = do-   ptr <- pooledMallocArray0 pool (length vals)-   pokeArray0 marker ptr vals-   return ptr
− Foreign/Marshal/Safe.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Safe--- Copyright   :  (c) The FFI task force 2003--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Marshalling support------ Safe API Only.-----------------------------------------------------------------------------------module Foreign.Marshal.Safe {-# DEPRECATED "Safe is now the default, please use Foreign.Marshal instead" #-}-        (-         -- | The module "Foreign.Marshal.Safe" re-exports the other modules in the-         -- @Foreign.Marshal@ hierarchy:-          module Foreign.Marshal.Alloc-        , module Foreign.Marshal.Array-        , module Foreign.Marshal.Error-        , module Foreign.Marshal.Pool-        , module Foreign.Marshal.Utils-        ) where--import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Marshal.Error-import Foreign.Marshal.Pool-import Foreign.Marshal.Utils-
− Foreign/Marshal/Unsafe.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Unsafe--- Copyright   :  (c) The FFI task force 2003--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Marshalling support. Unsafe API.-----------------------------------------------------------------------------------module Foreign.Marshal.Unsafe (-        -- * Unsafe functions-        unsafeLocalState-    ) where--import GHC.IO--{- |-Sometimes an external entity is a pure function, except that it passes-arguments and/or results via pointers.  The function-@unsafeLocalState@ permits the packaging of such entities as pure-functions.  --The only IO operations allowed in the IO action passed to-@unsafeLocalState@ are (a) local allocation (@alloca@, @allocaBytes@-and derived operations such as @withArray@ and @withCString@), and (b)-pointer operations (@Foreign.Storable@ and @Foreign.Ptr@) on the-pointers to local storage, and (c) foreign functions whose only-observable effect is to read and/or write the locally allocated-memory.  Passing an IO operation that does not obey these rules-results in undefined behaviour.--It is expected that this operation will be-replaced in a future revision of Haskell.--}-unsafeLocalState :: IO a -> a-unsafeLocalState = unsafeDupablePerformIO-
− Foreign/Marshal/Utils.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Marshal.Utils--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ Utilities for primitive marshaling-----------------------------------------------------------------------------------module Foreign.Marshal.Utils (-  -- * General marshalling utilities--  -- ** Combined allocation and marshalling-  ---  with,-  new,--  -- ** Marshalling of Boolean values (non-zero corresponds to 'True')-  ---  fromBool,-  toBool,--  -- ** Marshalling of Maybe values-  ---  maybeNew,-  maybeWith,-  maybePeek,--  -- ** Marshalling lists of storable objects-  ---  withMany,--  -- ** Haskellish interface to memcpy and memmove-  -- | (argument order: destination, source)-  ---  copyBytes,-  moveBytes,--  -- ** Filling up memory area with required values-  ---  fillBytes,-) where--import Data.Maybe-import Foreign.Ptr              ( Ptr, nullPtr )-import Foreign.Storable         ( Storable(poke) )-import Foreign.C.Types          ( CSize(..), CInt(..) )-import Foreign.Marshal.Alloc    ( malloc, alloca )-import Data.Word                ( Word8 )--import GHC.Real                 ( fromIntegral )-import GHC.Num-import GHC.Base---- combined allocation and marshalling--- --------------------------------------- |Allocate a block of memory and marshal a value into it--- (the combination of 'malloc' and 'poke').--- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf'--- method from the instance of 'Storable' for the appropriate type.------ The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or--- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required.----new     :: Storable a => a -> IO (Ptr a)-new val  =-  do-    ptr <- malloc-    poke ptr val-    return ptr---- |@'with' val f@ executes the computation @f@, passing as argument--- a pointer to a temporarily allocated block of memory into which--- @val@ has been marshalled (the combination of 'alloca' and 'poke').------ The memory is freed when @f@ terminates (either normally or via an--- exception), so the pointer passed to @f@ must /not/ be used after this.----with       :: Storable a => a -> (Ptr a -> IO b) -> IO b-with val f  =-  alloca $ \ptr -> do-    poke ptr val-    f ptr---- marshalling of Boolean values (non-zero corresponds to 'True')--- --------------------------------- |Convert a Haskell 'Bool' to its numeric representation----fromBool       :: Num a => Bool -> a-fromBool False  = 0-fromBool True   = 1---- |Convert a Boolean in numeric representation to a Haskell value----toBool :: (Eq a, Num a) => a -> Bool-toBool  = (/= 0)----- marshalling of Maybe values--- ------------------------------- |Allocate storage and marshal a storable value wrapped into a 'Maybe'------ * the 'nullPtr' is used to represent 'Nothing'----maybeNew :: (      a -> IO (Ptr b))-         -> (Maybe a -> IO (Ptr b))-maybeNew  = maybe (return nullPtr)---- |Converts a @withXXX@ combinator into one marshalling a value wrapped--- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.----maybeWith :: (      a -> (Ptr b -> IO c) -> IO c)-          -> (Maybe a -> (Ptr b -> IO c) -> IO c)-maybeWith  = maybe ($ nullPtr)---- |Convert a peek combinator into a one returning 'Nothing' if applied to a--- 'nullPtr'----maybePeek                           :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)-maybePeek peek ptr | ptr == nullPtr  = return Nothing-                   | otherwise       = do a <- peek ptr; return (Just a)----- marshalling lists of storable objects--- ----------------------------------------- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of--- marshalled objects----withMany :: (a -> (b -> res) -> res)  -- withXXX combinator for one object-         -> [a]                       -- storable objects-         -> ([b] -> res)              -- action on list of marshalled obj.s-         -> res-withMany _       []     f = f []-withMany withFoo (x:xs) f = withFoo x $ \x' ->-                              withMany withFoo xs (\xs' -> f (x':xs'))----- Haskellish interface to memcpy and memmove--- ---------------------------------------------- |Copies the given number of bytes from the second area (source) into the--- first (destination); the copied areas may /not/ overlap----copyBytes-  :: Ptr a -- ^ Destination-  -> Ptr a -- ^ Source-  -> Int -- ^ Size in bytes-  -> IO ()-copyBytes dest src size = do-  _ <- memcpy dest src (fromIntegral size)-  return ()---- |Copies the given number of bytes from the second area (source) into the--- first (destination); the copied areas /may/ overlap----moveBytes-  :: Ptr a -- ^ Destination-  -> Ptr a -- ^ Source-  -> Int -- ^ Size in bytes-  -> IO ()-moveBytes dest src size = do-  _ <- memmove dest src (fromIntegral size)-  return ()---- Filling up memory area with required values--- ----------------------------------------------- |Fill a given number of bytes in memory area with a byte value.------ @since 4.8.0.0-fillBytes               :: Ptr a -> Word8 -> Int -> IO ()-fillBytes dest char size = do-  _ <- memset dest (fromIntegral char) (fromIntegral size)-  return ()---- auxiliary routines--- ----------------------- |Basic C routines needed for memory copying----foreign import ccall unsafe "string.h" memcpy  :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)-foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)-foreign import ccall unsafe "string.h" memset  :: Ptr a -> CInt  -> CSize -> IO (Ptr a)
− Foreign/Ptr.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Ptr--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ This module provides typed pointers to foreign data.  It is part--- of the Foreign Function Interface (FFI) and will normally be--- imported via the "Foreign" module.-----------------------------------------------------------------------------------module Foreign.Ptr (--    -- * Data pointers--    Ptr,-    nullPtr,-    castPtr,-    plusPtr,-    alignPtr,-    minusPtr,--    -- * Function pointers--    FunPtr,-    nullFunPtr,-    castFunPtr,-    castFunPtrToPtr,-    castPtrToFunPtr,--    freeHaskellFunPtr,-    -- Free the function pointer created by foreign export dynamic.--    -- * Integral types with lossless conversion to and from pointers-    IntPtr(..),-    ptrToIntPtr,-    intPtrToPtr,-    WordPtr(..),-    ptrToWordPtr,-    wordPtrToPtr--    -- See Note [Exporting constructors of marshallable foreign types]-    -- for why the constructors for IntPtr and WordPtr are exported.- ) where--import GHC.Ptr-import GHC.Base-import GHC.Num-import GHC.Read-import GHC.Real-import GHC.Show-import GHC.Enum-import GHC.Ix--import Data.Bits-import Foreign.Storable ( Storable(..) )---- | Release the storage associated with the given 'FunPtr', which--- must have been obtained from a wrapper stub.  This should be called--- whenever the return value from a foreign import wrapper function is--- no longer required; otherwise, the storage it uses will leak.-foreign import ccall unsafe "freeHaskellFunctionPtr"-    freeHaskellFunPtr :: FunPtr a -> IO ()--#include "HsBaseConfig.h"-#include "CTypes.h"---- | An unsigned integral type that can be losslessly converted to and from--- @Ptr@. This type is also compatible with the C99 type @uintptr_t@, and--- can be marshalled to and from that type safely.-INTEGRAL_TYPE(WordPtr,"uintptr_t",Word)-        -- Word and Int are guaranteed pointer-sized in GHC---- | A signed integral type that can be losslessly converted to and from--- @Ptr@.  This type is also compatible with the C99 type @intptr_t@, and--- can be marshalled to and from that type safely.-INTEGRAL_TYPE(IntPtr,"intptr_t",Int)-        -- Word and Int are guaranteed pointer-sized in GHC---- | casts a @Ptr@ to a @WordPtr@-ptrToWordPtr :: Ptr a -> WordPtr-ptrToWordPtr (Ptr a#) = WordPtr (W# (int2Word# (addr2Int# a#)))---- | casts a @WordPtr@ to a @Ptr@-wordPtrToPtr :: WordPtr -> Ptr a-wordPtrToPtr (WordPtr (W# w#)) = Ptr (int2Addr# (word2Int# w#))---- | casts a @Ptr@ to an @IntPtr@-ptrToIntPtr :: Ptr a -> IntPtr-ptrToIntPtr (Ptr a#) = IntPtr (I# (addr2Int# a#))---- | casts an @IntPtr@ to a @Ptr@-intPtrToPtr :: IntPtr -> Ptr a-intPtrToPtr (IntPtr (I# i#)) = Ptr (int2Addr# i#)--{--Note [Exporting constructors of marshallable foreign types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One might expect that IntPtr, WordPtr, and the other newtypes in the-Foreign.C.Types and System.Posix.Types modules to be abstract, but this is not-the case in GHC (see #5229 and #11983). In fact, we deliberately export-the constructors for these datatypes in order to satisfy a requirement of the-Haskell 2010 Report (§ 8.4.2) that if a newtype is used in a foreign-declaration, then its constructor must be visible.--This requirement was motivated by the fact that using a type in a foreign-declaration necessarily exposes some information about the type to the user,-so being able to use abstract types in a foreign declaration breaks their-abstraction (see #3008). As a result, the constructors of all FFI-related-newtypes in base must be exported in order to be useful for FFI programming,-even at the cost of exposing their underlying, architecture-dependent types.--}
− Foreign/Safe.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Safe--- Copyright   :  (c) The FFI task force 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ A collection of data types, classes, and functions for interfacing--- with another programming language.------ Safe API Only.-----------------------------------------------------------------------------------module Foreign.Safe {-# DEPRECATED "Safe is now the default, please use Foreign instead" #-}-        ( module Data.Bits-        , module Data.Int-        , module Data.Word-        , module Foreign.Ptr-        , module Foreign.ForeignPtr-        , module Foreign.StablePtr-        , module Foreign.Storable-        , module Foreign.Marshal-        ) where--import Data.Bits-import Data.Int-import Data.Word-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.StablePtr-import Foreign.Storable-import Foreign.Marshal-
− Foreign/StablePtr.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.StablePtr--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ This module is part of the Foreign Function Interface (FFI) and will usually--- be imported via the module "Foreign".------------------------------------------------------------------------------------module Foreign.StablePtr-        ( -- * Stable references to Haskell values-          StablePtr          -- abstract-        , newStablePtr-        , deRefStablePtr-        , freeStablePtr-        , castStablePtrToPtr-        , castPtrToStablePtr-        , -- ** The C-side interface--          -- $cinterface-        ) where--import GHC.Stable---- $cinterface------ The following definition is available to C programs inter-operating with--- Haskell code when including the header @HsFFI.h@.------ > typedef void *HsStablePtr;  /* C representation of a StablePtr */------ Note that no assumptions may be made about the values representing stable--- pointers.  In fact, they need not even be valid memory addresses.  The only--- guarantee provided is that if they are passed back to Haskell land, the--- function 'deRefStablePtr' will be able to reconstruct the--- Haskell value referred to by the stable pointer.-
− Foreign/Storable.hs 
@@ -1,282 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  Foreign.Storable--- Copyright   :  (c) The FFI task force 2001--- License     :  see libraries/base/LICENSE--- --- Maintainer  :  ffi@haskell.org--- Stability   :  provisional--- Portability :  portable------ The module "Foreign.Storable" provides most elementary support for--- marshalling and is part of the language-independent portion of the--- Foreign Function Interface (FFI), and will normally be imported via--- the "Foreign" module.-----------------------------------------------------------------------------------module Foreign.Storable-        ( Storable(-             sizeOf,-             alignment,-             peekElemOff,-             pokeElemOff,-             peekByteOff,-             pokeByteOff,-             peek,-             poke)-        ) where---#include "MachDeps.h"-#include "HsBaseConfig.h"--import GHC.Storable-import GHC.Stable       ( StablePtr )-import GHC.Num-import GHC.Int-import GHC.Word-import GHC.Ptr-import GHC.Base-import GHC.Fingerprint.Type-import Data.Bits-import GHC.Real--{- |-The member functions of this class facilitate writing values of-primitive types to raw memory (which may have been allocated with the-above mentioned routines) and reading values from blocks of raw-memory.  The class, furthermore, includes support for computing the-storage requirements and alignment restrictions of storable types.--Memory addresses are represented as values of type @'Ptr' a@, for some-@a@ which is an instance of class 'Storable'.  The type argument to-'Ptr' helps provide some valuable type safety in FFI code (you can\'t-mix pointers of different types without an explicit cast), while-helping the Haskell type system figure out which marshalling method is-needed for a given pointer.--All marshalling between Haskell and a foreign language ultimately-boils down to translating Haskell data structures into the binary-representation of a corresponding data structure of the foreign-language and vice versa.  To code this marshalling in Haskell, it is-necessary to manipulate primitive data types stored in unstructured-memory blocks.  The class 'Storable' facilitates this manipulation on-all types for which it is instantiated, which are the standard basic-types of Haskell, the fixed size @Int@ types ('Int8', 'Int16',-'Int32', 'Int64'), the fixed size @Word@ types ('Word8', 'Word16',-'Word32', 'Word64'), 'StablePtr', all types from "Foreign.C.Types",-as well as 'Ptr'.--}--class Storable a where-   {-# MINIMAL sizeOf, alignment,-               (peek | peekElemOff | peekByteOff),-               (poke | pokeElemOff | pokeByteOff) #-}--   sizeOf      :: a -> Int-   -- ^ Computes the storage requirements (in bytes) of the argument.-   -- The value of the argument is not used.--   alignment   :: a -> Int-   -- ^ Computes the alignment constraint of the argument.  An-   -- alignment constraint @x@ is fulfilled by any address divisible-   -- by @x@. The alignment must be a power of two if this instance-   -- is to be used with 'alloca' or 'allocaArray'.  The value of-   -- the argument is not used.--   peekElemOff :: Ptr a -> Int      -> IO a-   -- ^       Read a value from a memory area regarded as an array-   --         of values of the same kind.  The first argument specifies-   --         the start address of the array and the second the index into-   --         the array (the first element of the array has index-   --         @0@).  The following equality holds,-   -- -   -- > peekElemOff addr idx = IOExts.fixIO $ \result ->-   -- >   peek (addr `plusPtr` (idx * sizeOf result))-   ---   --         Note that this is only a specification, not-   --         necessarily the concrete implementation of the-   --         function.--   pokeElemOff :: Ptr a -> Int -> a -> IO ()-   -- ^       Write a value to a memory area regarded as an array of-   --         values of the same kind.  The following equality holds:-   -- -   -- > pokeElemOff addr idx x = -   -- >   poke (addr `plusPtr` (idx * sizeOf x)) x--   peekByteOff :: Ptr b -> Int      -> IO a-   -- ^       Read a value from a memory location given by a base-   --         address and offset.  The following equality holds:-   ---   -- > peekByteOff addr off = peek (addr `plusPtr` off)--   pokeByteOff :: Ptr b -> Int -> a -> IO ()-   -- ^       Write a value to a memory location given by a base-   --         address and offset.  The following equality holds:-   ---   -- > pokeByteOff addr off x = poke (addr `plusPtr` off) x-  -   peek        :: Ptr a      -> IO a-   -- ^ Read a value from the given memory location.-   ---   --  Note that the peek and poke functions might require properly-   --  aligned addresses to function correctly.  This is architecture-   --  dependent; thus, portable code should ensure that when peeking or-   --  poking values of some type @a@, the alignment-   --  constraint for @a@, as given by the function-   --  'alignment' is fulfilled.--   poke        :: Ptr a -> a -> IO ()-   -- ^ Write the given value to the given memory location.  Alignment-   -- restrictions might apply; see 'peek'.- -   -- circular default instances-   peekElemOff = peekElemOff_ undefined-      where peekElemOff_ :: a -> Ptr a -> Int -> IO a-            peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)-   pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val--   peekByteOff ptr off = peek (ptr `plusPtr` off)-   pokeByteOff ptr off = poke (ptr `plusPtr` off)--   peek ptr = peekElemOff ptr 0-   poke ptr = pokeElemOff ptr 0---- | @since 4.9.0.0-instance Storable () where-  sizeOf _ = 0-  alignment _ = 1-  peek _ = return ()-  poke _ _ = return ()---- System-dependent, but rather obvious instances---- | @since 2.01-instance Storable Bool where-   sizeOf _          = sizeOf (undefined::HTYPE_INT)-   alignment _       = alignment (undefined::HTYPE_INT)-   peekElemOff p i   = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i-   pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT)--#define STORABLE(T,size,align,read,write)       \-instance Storable (T) where {                   \-    sizeOf    _ = size;                         \-    alignment _ = align;                        \-    peekElemOff = read;                         \-    pokeElemOff = write }---- | @since 2.01-STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,-         readWideCharOffPtr,writeWideCharOffPtr)---- | @since 2.01-STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT,-         readIntOffPtr,writeIntOffPtr)---- | @since 2.01-STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD,-         readWordOffPtr,writeWordOffPtr)---- | @since 2.01-STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR,-         readPtrOffPtr,writePtrOffPtr)---- | @since 2.01-STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR,-         readFunPtrOffPtr,writeFunPtrOffPtr)---- | @since 2.01-STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR,-         readStablePtrOffPtr,writeStablePtrOffPtr)---- | @since 2.01-STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT,-         readFloatOffPtr,writeFloatOffPtr)---- | @since 2.01-STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE,-         readDoubleOffPtr,writeDoubleOffPtr)---- | @since 2.01-STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,-         readWord8OffPtr,writeWord8OffPtr)---- | @since 2.01-STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,-         readWord16OffPtr,writeWord16OffPtr)---- | @since 2.01-STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,-         readWord32OffPtr,writeWord32OffPtr)---- | @since 2.01-STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,-         readWord64OffPtr,writeWord64OffPtr)---- | @since 2.01-STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,-         readInt8OffPtr,writeInt8OffPtr)---- | @since 2.01-STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,-         readInt16OffPtr,writeInt16OffPtr)---- | @since 2.01-STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,-         readInt32OffPtr,writeInt32OffPtr)---- | @since 2.01-STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,-         readInt64OffPtr,writeInt64OffPtr)---- | @since 4.8.0.0-instance (Storable a, Integral a) => Storable (Ratio a) where-    sizeOf _    = 2 * sizeOf (undefined :: a)-    alignment _ = alignment (undefined :: a )-    peek p           = do-                        q <- return $ castPtr p-                        r <- peek q-                        i <- peekElemOff q 1-                        return (r % i)-    poke p (r :% i)  = do-                        q <-return $  (castPtr p)-                        poke q r-                        pokeElemOff q 1 i---- XXX: here to avoid orphan instance in GHC.Fingerprint--- | @since 4.4.0.0-instance Storable Fingerprint where-  sizeOf _ = 16-  alignment _ = 8-  peek = peekFingerprint-  poke = pokeFingerprint---- peek/poke in fixed BIG-endian 128-bit format-peekFingerprint :: Ptr Fingerprint -> IO Fingerprint-peekFingerprint p0 = do-      let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64-          peekW64 _  0  !i = return i-          peekW64 !p !n !i = do-                w8 <- peek p-                peekW64 (p `plusPtr` 1) (n-1) -                    ((i `shiftL` 8) .|. fromIntegral w8)--      high <- peekW64 (castPtr p0) 8 0-      low  <- peekW64 (castPtr p0 `plusPtr` 8) 8 0-      return (Fingerprint high low)--pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()-pokeFingerprint p0 (Fingerprint high low) = do-      let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()-          pokeW64 _ 0  _  = return ()-          pokeW64 p !n !i = do-                pokeElemOff p (n-1) (fromIntegral i)-                pokeW64 p (n-1) (i `shiftR` 8)--      pokeW64 (castPtr p0) 8 high-      pokeW64 (castPtr p0 `plusPtr` 8) 8 low
− GHC/Arr.hs 
@@ -1,646 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RoleAnnotations #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Arr--- Copyright   :  (c) The University of Glasgow, 1994-2000--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ GHC\'s array implementation.-----------------------------------------------------------------------------------module GHC.Arr (-        Ix(..), Array(..), STArray(..),--        arrEleBottom, array, listArray,-        (!), safeRangeSize, negRange, safeIndex, badSafeIndex,-        bounds, numElements, numElementsSTArray, indices, elems,-        assocs, accumArray, adjust, (//), accum,-        amap, ixmap,-        eqArray, cmpArray, cmpIntArray,-        newSTArray, boundsSTArray,-        readSTArray, writeSTArray,-        freezeSTArray, thawSTArray,-        foldlElems, foldlElems', foldl1Elems,-        foldrElems, foldrElems', foldr1Elems,--        -- * Unsafe operations-        fill, done,-        unsafeArray, unsafeArray',-        lessSafeIndex, unsafeAt, unsafeReplace,-        unsafeAccumArray, unsafeAccumArray', unsafeAccum,-        unsafeReadSTArray, unsafeWriteSTArray,-        unsafeFreezeSTArray, unsafeThawSTArray,-    ) where--import GHC.Num-import GHC.ST-import GHC.Base-import GHC.List-import GHC.Ix-import GHC.Show--infixl 9  !, //--default ()---- | The type of immutable non-strict (boxed) arrays--- with indices in @i@ and elements in @e@.-data Array i e-   = Array            !i         -- the lower bound, l-                      !i         -- the upper bound, u-       {-# UNPACK #-} !Int       -- A cache of (rangeSize (l,u))-                                 -- used to make sure an index is-                                 -- really in range-                      (Array# e) -- The actual elements---- | Mutable, boxed, non-strict arrays in the 'ST' monad.  The type--- arguments are as follows:------  * @s@: the state variable argument for the 'ST' type------  * @i@: the index type of the array (should be an instance of 'Ix')------  * @e@: the element type of the array.----data STArray s i e-  = STArray           !i               -- the lower bound, l-                      !i               -- the upper bound, u-      {-# UNPACK #-}  !Int             -- A cache of (rangeSize (l,u))-                                       -- used to make sure an index is-                                       -- really in range-                   (MutableArray# s e) -- The actual elements-        -- No Ix context for STArray.  They are stupid,-        -- and force an Ix context on the equality instance.---- Index types should have nominal role, because of Ix class. See also #9220.-type role Array nominal representational-type role STArray nominal nominal representational---- Just pointer equality on mutable arrays:--- | @since 2.01-instance Eq (STArray s i e) where-    STArray _ _ _ arr1# == STArray _ _ _ arr2# =-        isTrue# (sameMutableArray# arr1# arr2#)--------------------------------------------------------------------------- Operations on immutable arrays--{-# NOINLINE arrEleBottom #-}-arrEleBottom :: a-arrEleBottom = errorWithoutStackTrace "(Array.!): undefined array element"---- | Construct an array with the specified bounds and containing values--- for given indices within these bounds.------ The array is undefined (i.e. bottom) if any index in the list is--- out of bounds.  The Haskell 2010 Report further specifies that if any--- two associations in the list have the same index, the value at that--- index is undefined (i.e. bottom).  However in GHC's implementation,--- the value at such an index is the value part of the last association--- with that index in the list.------ Because the indices must be checked for these errors, 'array' is--- strict in the bounds argument and in the indices of the association--- list, but non-strict in the values.  Thus, recurrences such as the--- following are possible:------ > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]])------ Not every index within the bounds of the array need appear in the--- association list, but the values associated with indices that do not--- appear will be undefined (i.e. bottom).------ If, in any dimension, the lower bound is greater than the upper bound,--- then the array is legal, but empty.  Indexing an empty array always--- gives an array-bounds error, but 'bounds' still yields the bounds--- with which the array was constructed.-{-# INLINE array #-}-array :: Ix i-        => (i,i)        -- ^ a pair of /bounds/, each of the index type-                        -- of the array.  These bounds are the lowest and-                        -- highest indices in the array, in that order.-                        -- For example, a one-origin vector of length-                        -- @10@ has bounds @(1,10)@, and a one-origin @10@-                        -- by @10@ matrix has bounds @((1,1),(10,10))@.-        -> [(i, e)]     -- ^ a list of /associations/ of the form-                        -- (/index/, /value/).  Typically, this list will-                        -- be expressed as a comprehension.  An-                        -- association @(i, x)@ defines the value of-                        -- the array at index @i@ to be @x@.-        -> Array i e-array (l,u) ies-    = let n = safeRangeSize (l,u)-      in unsafeArray' (l,u) n-                      [(safeIndex (l,u) n i, e) | (i, e) <- ies]--{-# INLINE unsafeArray #-}-unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e-unsafeArray b ies = unsafeArray' b (rangeSize b) ies--{-# INLINE unsafeArray' #-}-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# #) ->-            foldr (fill marr#) (done l u n marr#) ies s2#)--{-# INLINE fill #-}-fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a--- NB: put the \s after the "=" so that 'fill'---     inlines when applied to three args-fill marr# (I# i#, e) next- = \s1# -> case writeArray# marr# i# e s1# of-             s2# -> next s2#--{-# INLINE done #-}-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#-  = \s1# -> case unsafeFreezeArray# marr# s1# of-              (# s2#, arr# #) -> (# s2#, Array l u n arr# #)---- | Construct an array from a pair of bounds and a list of values in--- index order.-{-# INLINE listArray #-}-listArray :: Ix i => (i,i) -> [e] -> Array i e-listArray (l,u) es = runST (ST $ \s1# ->-    case safeRangeSize (l,u)            of { n@(I# n#) ->-    case newArray# n# arrEleBottom s1#  of { (# s2#, marr# #) ->-      let-        go y r = \ i# s3# ->-            case writeArray# marr# i# y s3# of-              s4# -> if (isTrue# (i# ==# n# -# 1#))-                     then s4#-                     else r (i# +# 1#) s4#-      in-        done l u n marr# (-          if n == 0-          then s2#-          else foldr go (\_ s# -> s#) es 0# s2#)}})---- | The value at the given index in an array.-{-# INLINE (!) #-}-(!) :: Ix i => Array i e -> i -> e-(!) arr@(Array l u n _) i = unsafeAt arr $ safeIndex (l,u) n i--{-# INLINE (!#) #-}-(!#) :: Ix i => Array i e -> i -> (# e #)-(!#) arr@(Array l u n _) i = unsafeAt# arr $ safeIndex (l,u) n i--{-# INLINE safeRangeSize #-}-safeRangeSize :: Ix i => (i, i) -> Int-safeRangeSize (l,u) = let r = rangeSize (l, u)-                      in if r < 0 then negRange-                                  else r---- Don't inline this error message everywhere!!-negRange :: Int   -- Uninformative, but Ix does not provide Show-negRange = errorWithoutStackTrace "Negative range size"--{-# INLINE[1] safeIndex #-}--- See Note [Double bounds-checking of index values]--- Inline *after* (!) so the rules can fire--- Make sure it is strict in n-safeIndex :: Ix i => (i, i) -> Int -> i -> Int-safeIndex (l,u) n@(I# _) i-  | (0 <= i') && (i' < n) = i'-  | otherwise             = badSafeIndex i' n-  where-    i' = index (l,u) i---- See Note [Double bounds-checking of index values]-{-# RULES-"safeIndex/I"       safeIndex = lessSafeIndex :: (Int,Int) -> Int -> Int -> Int-"safeIndex/(I,I)"   safeIndex = lessSafeIndex :: ((Int,Int),(Int,Int)) -> Int -> (Int,Int) -> Int-"safeIndex/(I,I,I)" safeIndex = lessSafeIndex :: ((Int,Int,Int),(Int,Int,Int)) -> Int -> (Int,Int,Int) -> Int-  #-}--lessSafeIndex :: Ix i => (i, i) -> Int -> i -> Int--- See Note [Double bounds-checking of index values]--- Do only (A), the semantic check-lessSafeIndex (l,u) _ i = index (l,u) i---- Don't inline this long error message everywhere!!-badSafeIndex :: Int -> Int -> Int-badSafeIndex i' n = errorWithoutStackTrace ("Error in array index; " ++ show i' ++-                        " not in range [0.." ++ show n ++ ")")--{-# INLINE unsafeAt #-}-unsafeAt :: Array i e -> Int -> e-unsafeAt (Array _ _ _ arr#) (I# i#) =-    case indexArray# arr# i# of (# e #) -> e---- | Look up an element in an array without forcing it-unsafeAt# :: Array i e -> Int -> (# e #)-unsafeAt# (Array _ _ _ arr#) (I# i#) = indexArray# arr# i#---- | A convenient version of unsafeAt#-unsafeAtA :: Applicative f-          => Array i e -> Int -> f e-unsafeAtA ary i = case unsafeAt# ary i of (# e #) -> pure e---- | The bounds with which an array was constructed.-{-# INLINE bounds #-}-bounds :: Array i e -> (i,i)-bounds (Array l u _ _) = (l,u)---- | The number of elements in the array.-{-# INLINE numElements #-}-numElements :: Array i e -> Int-numElements (Array _ _ n _) = n---- | The list of indices of an array in ascending order.-{-# INLINE indices #-}-indices :: Ix i => Array i e -> [i]-indices (Array l u _ _) = range (l,u)---- | The list of elements of an array in index order.-{-# INLINE elems #-}-elems :: Array i e -> [e]-elems arr@(Array _ _ n _) =-    [e | i <- [0 .. n - 1], e <- unsafeAtA arr i]---- | A right fold over the elements-{-# INLINABLE foldrElems #-}-foldrElems :: (a -> b -> b) -> b -> Array i a -> b-foldrElems f b0 = \ arr@(Array _ _ n _) ->-  let-    go i | i == n    = b0-         | (# e #) <- unsafeAt# arr i-         = f e (go (i+1))-  in go 0---- | A left fold over the elements-{-# INLINABLE foldlElems #-}-foldlElems :: (b -> a -> b) -> b -> Array i a -> b-foldlElems f b0 = \ arr@(Array _ _ n _) ->-  let-    go i | i == (-1) = b0-         | (# e #) <- unsafeAt# arr i-         = f (go (i-1)) e-  in go (n-1)---- | A strict right fold over the elements-{-# INLINABLE foldrElems' #-}-foldrElems' :: (a -> b -> b) -> b -> Array i a -> b-foldrElems' f b0 = \ arr@(Array _ _ n _) ->-  let-    go i a | i == (-1) = a-           | (# e #) <- unsafeAt# arr i-           = go (i-1) (f e $! a)-  in go (n-1) b0---- | A strict left fold over the elements-{-# INLINABLE foldlElems' #-}-foldlElems' :: (b -> a -> b) -> b -> Array i a -> b-foldlElems' f b0 = \ arr@(Array _ _ n _) ->-  let-    go i a | i == n    = a-           | (# e #) <- unsafeAt# arr i-           = go (i+1) (a `seq` f a e)-  in go 0 b0---- | A left fold over the elements with no starting value-{-# INLINABLE foldl1Elems #-}-foldl1Elems :: (a -> a -> a) -> Array i a -> a-foldl1Elems f = \ arr@(Array _ _ n _) ->-  let-    go i | i == 0    = unsafeAt arr 0-         | (# e #) <- unsafeAt# arr i-         = f (go (i-1)) e-  in-    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 :: (a -> a -> a) -> Array i a -> a-foldr1Elems f = \ arr@(Array _ _ n _) ->-  let-    go i | i == n-1  = unsafeAt arr i-         | (# e #) <- unsafeAt# arr i-         = f e (go (i + 1))-  in-    if n == 0 then errorWithoutStackTrace "foldr1: empty Array" else go 0---- | The list of associations of an array in index order.-{-# INLINE assocs #-}-assocs :: Ix i => Array i e -> [(i, e)]-assocs arr@(Array l u _ _) =-    [(i, e) | i <- range (l,u), let !(# e #) = arr !# i]---- | The 'accumArray' function deals with repeated indices in the association--- list using an /accumulating function/ which combines the values of--- associations with the same index.------ For example, given a list of values of some index type, @hist@--- produces a histogram of the number of occurrences of each index within--- a specified range:------ > hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b--- > hist bnds is = accumArray (+) 0 bnds [(i, 1) | i<-is, inRange bnds i]------ @accumArray@ is strict in each result of applying the accumulating--- function, although it is lazy in the initial value. Thus, unlike--- arrays built with 'array', accumulated arrays should not in general--- be recursive.-{-# INLINE accumArray #-}-accumArray :: Ix i-        => (e -> a -> e)        -- ^ accumulating function-        -> e                    -- ^ initial value-        -> (i,i)                -- ^ bounds of the array-        -> [(i, a)]             -- ^ association list-        -> Array i e-accumArray f initial (l,u) ies =-    let n = safeRangeSize (l,u)-    in unsafeAccumArray' f initial (l,u) n-                         [(safeIndex (l,u) n i, e) | (i, e) <- ies]--{-# INLINE unsafeAccumArray #-}-unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e-unsafeAccumArray f initial b ies = unsafeAccumArray' f initial b (rangeSize b) ies--{-# INLINE unsafeAccumArray' #-}-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# })--{-# INLINE adjust #-}-adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b--- See NB on 'fill'-adjust f marr# (I# i#, new) next-  = \s1# -> case readArray# marr# i# s1# of-                (# s2#, old #) ->-                    case writeArray# marr# i# (f old new) s2# of-                        s3# -> next s3#--{-# INLINE adjust' #-}-adjust' :: (e -> a -> e)-        -> MutableArray# s e-        -> (Int, a)-        -> STRep s b -> STRep s b-adjust' f marr# (I# i#, new) next-  = \s1# -> case readArray# marr# i# s1# of-                (# s2#, old #) ->-                    let !combined = f old new-                    in next (writeArray# marr# i# combined s2#)----- | Constructs an array identical to the first argument except that it has--- been updated by the associations in the right argument.--- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then------ > m//[((i,i), 0) | i <- [1..n]]------ is the same matrix, except with the diagonal zeroed.------ Repeated indices in the association list are handled as for 'array':--- Haskell 2010 specifies that the resulting array is undefined (i.e. bottom),--- but GHC's implementation uses the last association for each index.-{-# INLINE (//) #-}-(//) :: Ix i => Array i e -> [(i, e)] -> Array i e-arr@(Array l u n _) // ies =-    unsafeReplace arr [(safeIndex (l,u) n i, e) | (i, e) <- ies]--{-# INLINE unsafeReplace #-}-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))---- | @'accum' f@ takes an array and an association list and accumulates--- pairs from the list into the array with the accumulating function @f@.--- Thus 'accumArray' can be defined using 'accum':------ > accumArray f z b = accum f (array b [(i, z) | i <- range b])------ @accum@ is strict in all the results of applying the accumulation.--- However, it is lazy in the initial values of the array.-{-# INLINE accum #-}-accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e-accum f arr@(Array l u n _) ies =-    unsafeAccum f arr [(safeIndex (l,u) n i, e) | (i, e) <- ies]--{-# INLINE unsafeAccum #-}-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 #-}  -- 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# #) ->-          let go i s#-                | i == n    = done l u n marr# s#-                | (# e #) <- unsafeAt# arr i-                = fill marr# (i, f e) (go (i+1)) s#-          in go 0 s2# )--{- Note [amap]-~~~~~~~~~~~~~~-amap was originally defined like this:-- amap f arr@(Array l u n _) =-     unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]]--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.--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. #8767)--}----- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost--- 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  -- See Note [amap]- #-}---- Second functor law:-{-# RULES-"amap/amap" forall f g a . amap f (amap g a) = amap (f . g) a- #-}---- | 'ixmap' allows for transformations on array indices.--- It may be thought of as providing function composition on the right--- with the mapping that the original array embodies.------ A similar transformation of array values may be achieved using 'fmap'--- from the 'Array' instance of the 'Functor' class.-{-# INLINE ixmap #-}-ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e-ixmap (l,u) f arr =-    array (l,u) [(i, arr ! f i) | i <- range (l,u)]--{-# INLINE eqArray #-}-eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool-eqArray arr1@(Array l1 u1 n1 _) arr2@(Array l2 u2 n2 _) =-    if n1 == 0 then n2 == 0 else-    l1 == l2 && u1 == u2 &&-    and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. n1 - 1]]--{-# INLINE [1] cmpArray #-}-cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering-cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2)--{-# INLINE cmpIntArray #-}-cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering-cmpIntArray arr1@(Array l1 u1 n1 _) arr2@(Array l2 u2 n2 _) =-    if n1 == 0 then-        if n2 == 0 then EQ else LT-    else if n2 == 0 then GT-    else case compare l1 l2 of-             EQ    -> foldr cmp (compare u1 u2) [0 .. (n1 `min` n2) - 1]-             other -> other-  where-    cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of-        EQ    -> rest-        other -> other--{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-}--------------------------------------------------------------------------- Array instances---- | @since 2.01-instance Functor (Array i) where-    fmap = amap--    {-# INLINE (<$) #-}-    x <$ Array l u n@(I# n#) _ =-        -- Sadly we can't just use 'newSTArray' (with 'unsafeFreezeSTArray')-        -- since that would require proof that the indices of the original array-        -- are instances of 'Ix'.-        runST $ ST $ \s1# ->-            case newArray# n# x s1# of-                (# s2#, marr# #) -> done l u n marr# s2#---- | @since 2.01-instance (Ix i, Eq e) => Eq (Array i e) where-    (==) = eqArray---- | @since 2.01-instance (Ix i, Ord e) => Ord (Array i e) where-    compare = cmpArray---- | @since 2.01-instance (Ix a, Show a, Show b) => Show (Array a b) where-    showsPrec p a =-        showParen (p > appPrec) $-        showString "array " .-        showsPrec appPrec1 (bounds a) .-        showChar ' ' .-        showsPrec appPrec1 (assocs a)-        -- Precedence of 'array' is the precedence of application---- The Read instance is in GHC.Read--------------------------------------------------------------------------- Operations on mutable arrays--{--Idle ADR question: What's the tradeoff here between flattening these-datatypes into @STArray ix ix (MutableArray# s elt)@ and using-it as is?  As I see it, the former uses slightly less heap and-provides faster access to the individual parts of the bounds while the-code used has the benefit of providing a ready-made @(lo, hi)@ pair as-required by many array-related functions.  Which wins? Is the-difference significant (probably not).--Idle AJG answer: When I looked at the outputted code (though it was 2-years ago) it seems like you often needed the tuple, and we build-it frequently. Now we've got the overloading specialiser things-might be different, though.--}--{-# INLINE newSTArray #-}-newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)-newSTArray (l,u) initial = ST $ \s1# ->-    case safeRangeSize (l,u)            of { n@(I# n#) ->-    case newArray# n# initial s1#       of { (# s2#, marr# #) ->-    (# s2#, STArray l u n marr# #) }}--{-# INLINE boundsSTArray #-}-boundsSTArray :: STArray s i e -> (i,i)-boundsSTArray (STArray l u _ _) = (l,u)--{-# INLINE numElementsSTArray #-}-numElementsSTArray :: STArray s i e -> Int-numElementsSTArray (STArray _ _ n _) = n--{-# INLINE readSTArray #-}-readSTArray :: Ix i => STArray s i e -> i -> ST s e-readSTArray marr@(STArray l u n _) i =-    unsafeReadSTArray marr (safeIndex (l,u) n i)--{-# INLINE unsafeReadSTArray #-}-unsafeReadSTArray :: STArray s i e -> Int -> ST s e-unsafeReadSTArray (STArray _ _ _ marr#) (I# i#)-    = ST $ \s1# -> readArray# marr# i# s1#--{-# INLINE writeSTArray #-}-writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s ()-writeSTArray marr@(STArray l u n _) i e =-    unsafeWriteSTArray marr (safeIndex (l,u) n i) e--{-# INLINE unsafeWriteSTArray #-}-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#, () #)--------------------------------------------------------------------------- Moving between mutable and immutable--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#-                    | otherwise =-            case readArray# marr# i# s3# of { (# s4#, e #) ->-            case writeArray# marr'# i# e s4# of { s5# ->-            copy (i# +# 1#) s5# }} in-    case copy 0# s2#                    of { s3# ->-    case unsafeFreezeArray# marr'# s3#  of { (# s4#, arr# #) ->-    (# s4#, Array l u n arr# #) }}}--{-# INLINE unsafeFreezeSTArray #-}-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 :: 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#-                    | otherwise =-            case indexArray# arr# i#    of { (# e #) ->-            case writeArray# marr# i# e s3# of { s4# ->-            copy (i# +# 1#) s4# }} in-    case copy 0# s2#                    of { s3# ->-    (# s3#, STArray l u n marr# #) }}--{-# INLINE unsafeThawSTArray #-}-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# #) }
− GHC/Base.hs 
@@ -1,1708 +0,0 @@-{---The overall structure of the GHC Prelude is a bit tricky.--  a) We want to avoid "orphan modules", i.e. ones with instance-        decls that don't belong either to a tycon or a class-        defined in the same module--  b) We want to avoid giant modules--So the rough structure is as follows, in (linearised) dependency order---GHC.Prim        Has no implementation.  It defines built-in things, and-                by importing it you bring them into scope.-                The source file is GHC.Prim.hi-boot, which is just-                copied to make GHC.Prim.hi--GHC.Base        Classes: Eq, Ord, Functor, Monad-                Types:   list, (), Int, Bool, Ordering, Char, String--Data.Tuple      Types: tuples, plus instances for GHC.Base classes--GHC.Show        Class: Show, plus instances for GHC.Base/GHC.Tup types--GHC.Enum        Class: Enum,  plus instances for GHC.Base/GHC.Tup types--Data.Maybe      Type: Maybe, plus instances for GHC.Base classes--GHC.List        List functions--GHC.Num         Class: Num, plus instances for Int-                Type:  Integer, plus instances for all classes so far (Eq, Ord, Num, Show)--                Integer is needed here because it is mentioned in the signature-                of 'fromInteger' in class Num--GHC.Real        Classes: Real, Integral, Fractional, RealFrac-                         plus instances for Int, Integer-                Types:  Ratio, Rational-                        plus instances for classes so far--                Rational is needed here because it is mentioned in the signature-                of 'toRational' in class Real--GHC.ST  The ST monad, instances and a few helper functions--Ix              Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples--GHC.Arr         Types: Array, MutableArray, MutableVar--                Arrays are used by a function in GHC.Float--GHC.Float       Classes: Floating, RealFloat-                Types:   Float, Double, plus instances of all classes so far--                This module contains everything to do with floating point.-                It is a big module (900 lines)-                With a bit of luck, many modules can be compiled without ever reading GHC.Float.hi---Other Prelude modules are much easier with fewer complex dependencies.--}--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE Unsafe #-}---- -Wno-orphans is needed for things like:--- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Base--- Copyright   :  (c) The University of Glasgow, 1992-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Basic data types and classes.-----------------------------------------------------------------------------------#include "MachDeps.h"--module GHC.Base-        (-        module GHC.Base,-        module GHC.Classes,-        module GHC.CString,-        module GHC.Magic,-        module GHC.Types,-        module GHC.Prim,        -- Re-export GHC.Prim and [boot] GHC.Err,-        module GHC.Prim.Ext,    -- to avoid lots of people having to-        module GHC.Err,         -- import it explicitly-        module GHC.Maybe-  )-        where--import GHC.Types-import GHC.Classes-import GHC.CString-import GHC.Magic-import GHC.Prim-import GHC.Prim.Ext-import GHC.Err-import GHC.Maybe-import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)--import GHC.Tuple (Solo (..))     -- Note [Depend on GHC.Tuple]-import GHC.Num.Integer ()        -- Note [Depend on GHC.Num.Integer]---- for 'class Semigroup'-import {-# SOURCE #-} GHC.Real (Integral)-import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault-                                              , stimesMaybe-                                              , stimesList-                                              , stimesIdempotentMonoid-                                              )---- $setup--- >>> import GHC.Num--infixr 9  .-infixr 5  ++-infixl 4  <$-infixl 1  >>, >>=-infixr 1  =<<-infixr 0  $, $!--infixl 4 <*>, <*, *>, <**>--default ()              -- Double isn't available yet--{--Note [Depend on GHC.Num.Integer]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The Integer type is special because GHC.CoreToStg.Prep.mkConvertNumLiteral-lookups names in ghc-bignum interfaces 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.Num.Integer is compiled before-any other module.--The danger is that if the build system doesn't know about the implicit-dependency on Integer, it'll compile some base module before GHC.Num.Integer,-resulting in:-  Failed to load interface for ‘GHC.Num.Integer’-    There are files missing in the ‘ghc-bignum’ package,--Note that this is only a problem with the make-based build system. Hadrian-doesn't interleave compilation of modules from separate packages and respects-the dependency between `base` and `ghc-bignum`.--To ensure that GHC.Num.Integer is there, we must ensure that there is a visible-dependency on GHC.Num.Integer from every module in base.  We make GHC.Base-depend on GHC.Num.Integer; and everything else either depends on GHC.Base,-directly on GHC.Num.Integer, or does not have NoImplicitPrelude (and hence-depends on Prelude).--The lookup is only disabled for packages ghc-prim and ghc-bignum, which aren't-allowed to contain any Integer literal.---Note [Depend on GHC.Tuple]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Similarly, tuple syntax (or ()) creates an implicit dependency on-GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on-GHC.Num.Integer] --- to explain this to the build system.  We make GHC.Base-depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude.---}--#if 0--- for use when compiling GHC.Base itself doesn't work-data  Bool  =  False | True-data Ordering = LT | EQ | GT-data Char = C# Char#-type  String = [Char]-data Int = I# Int#-data  ()  =  ()-data [] a = MkNil--not True = False-(&&) True True = True-otherwise = True--build = errorWithoutStackTrace "urk"-foldr = errorWithoutStackTrace "urk"-#endif--infixr 6 <>---- | The class of semigroups (types with an associative binary operation).------ Instances should satisfy the following:------ [Associativity] @x '<>' (y '<>' z) = (x '<>' y) '<>' z@------ @since 4.9.0.0-class Semigroup a where-        -- | An associative operation.-        ---        -- >>> [1,2,3] <> [4,5,6]-        -- [1,2,3,4,5,6]-        (<>) :: a -> a -> a--        -- | Reduce a non-empty list with '<>'-        ---        -- The default definition should be sufficient, but this can be-        -- overridden for efficiency.-        ---        -- >>> import Data.List.NonEmpty (NonEmpty (..))-        -- >>> sconcat $ "Hello" :| [" ", "Haskell", "!"]-        -- "Hello Haskell!"-        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 \(\mathcal{O}(1)\) by-        -- picking @stimes = 'Data.Semigroup.stimesIdempotent'@ or @stimes =-        -- 'stimesIdempotentMonoid'@ respectively.-        ---        -- >>> stimes 4 [1]-        -- [1,1,1,1]-        stimes :: Integral b => b -> a -> a-        stimes = stimesDefault----- | The class of monoids (types with an associative binary operation that--- has an identity).  Instances should satisfy the following:------ [Right identity] @x '<>' 'mempty' = x@--- [Left identity]  @'mempty' '<>' x = x@--- [Associativity]  @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law)--- [Concatenation]  @'mconcat' = 'foldr' ('<>') 'mempty'@------ The method names refer to the monoid of lists under concatenation,--- but there are many other instances.------ Some types can be viewed as a monoid in more than one way,--- e.g. both addition and multiplication on numbers.--- In such cases we often define @newtype@s and make those instances--- of 'Monoid', e.g. 'Data.Semigroup.Sum' and 'Data.Semigroup.Product'.------ __NOTE__: 'Semigroup' is a superclass of 'Monoid' since /base-4.11.0.0/.-class Semigroup a => Monoid a where-        -- | Identity of 'mappend'-        ---        -- >>> "Hello world" <> mempty-        -- "Hello world"-        mempty  :: a--        -- | An associative operation-        ---        -- __NOTE__: This method is redundant and has the default-        -- implementation @'mappend' = ('<>')@ since /base-4.11.0.0/.-        -- Should it be implemented manually, since 'mappend' is a synonym for-        -- ('<>'), it is expected that the two functions are defined the same-        -- way. In a future GHC release 'mappend' will be removed from 'Monoid'.-        mappend :: a -> a -> a-        mappend = (<>)-        {-# INLINE mappend #-}--        -- | Fold a list using the monoid.-        ---        -- For most types, the default definition for 'mconcat' will be-        -- used, but the function is included in the class definition so-        -- that an optimized version can be provided for specific types.-        ---        -- >>> mconcat ["Hello", " ", "Haskell", "!"]-        -- "Hello Haskell!"-        mconcat :: [a] -> a-        mconcat = foldr mappend mempty-        {-# INLINE mconcat #-}-        -- INLINE in the hope of fusion with mconcat's argument (see !4890)---- | @since 4.9.0.0-instance Semigroup [a] where-        (<>) = (++)-        {-# INLINE (<>) #-}--        stimes = stimesList---- | @since 2.01-instance Monoid [a] where-        {-# INLINE mempty #-}-        mempty  = []-        {-# INLINE mconcat #-}-        mconcat xss = [x | xs <- xss, x <- xs]--- See Note: [List comprehensions and inlining]--{--Note: [List comprehensions and inlining]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The list monad operations are traditionally described in terms of concatMap:--xs >>= f = concatMap f xs--Similarly, mconcat for lists is just concat. Here in Base, however, we don't-have concatMap, and we'll refrain from adding it here so it won't have to be-hidden in imports. Instead, we use GHC's list comprehension desugaring-mechanism to define mconcat and the Applicative and Monad instances for lists.-We mark them INLINE because the inliner is not generally too keen to inline-build forms such as the ones these desugar to without our insistence.  Defining-these using list comprehensions instead of foldr has an additional potential-benefit, as described in compiler/GHC/HsToCore/ListComp.hs: if optimizations-needed to make foldr/build forms efficient are turned off, we'll get reasonably-efficient translations anyway.--}---- | @since 4.9.0.0-instance Semigroup (NonEmpty a) where-        (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)---- | @since 4.9.0.0-instance Semigroup b => Semigroup (a -> b) where-        f <> g = \x -> f x <> g x-        stimes n f e = stimes n (f e)---- | @since 2.01-instance Monoid b => Monoid (a -> b) where-        mempty _ = mempty---- | @since 4.9.0.0-instance Semigroup () where-        _ <> _      = ()-        sconcat _   = ()-        stimes  _ _ = ()---- | @since 2.01-instance Monoid () where-        -- Should it be strict?-        mempty        = ()-        mconcat _     = ()---- | @since 4.15-instance Semigroup a => Semigroup (Solo a) where-  Solo a <> Solo b = Solo (a <> b)-  stimes n (Solo a) = Solo (stimes n a)---- | @since 4.15-instance Monoid a => Monoid (Solo a) where-  mempty = Solo mempty---- | @since 4.9.0.0-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)---- | @since 2.01-instance (Monoid a, Monoid b) => Monoid (a,b) where-        mempty = (mempty, mempty)---- | @since 4.9.0.0-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)---- | @since 2.01-instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where-        mempty = (mempty, mempty, mempty)---- | @since 4.9.0.0-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)---- | @since 2.01-instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where-        mempty = (mempty, mempty, mempty, mempty)---- | @since 4.9.0.0-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)---- | @since 2.01-instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>-                Monoid (a,b,c,d,e) where-        mempty = (mempty, mempty, mempty, mempty, mempty)----- | @since 4.9.0.0-instance Semigroup Ordering where-    LT <> _ = LT-    EQ <> y = y-    GT <> _ = GT--    stimes = stimesIdempotentMonoid---- lexicographical ordering--- | @since 2.01-instance Monoid Ordering where-    mempty             = EQ---- | @since 4.9.0.0-instance Semigroup a => Semigroup (Maybe a) where-    Nothing <> b       = b-    a       <> Nothing = a-    Just a  <> Just b  = Just (a <> b)--    stimes = stimesMaybe---- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to--- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be--- turned into a monoid simply by adjoining an element @e@ not in @S@--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\"------ /Since 4.11.0/: constraint on inner @a@ value generalised from--- 'Monoid' to 'Semigroup'.------ @since 2.01-instance Semigroup a => Monoid (Maybe a) where-    mempty = Nothing---- | @since 4.15-instance Applicative Solo where-  pure = Solo--  -- Note: we really want to match strictly here. This lets us write,-  -- for example,-  ---  -- forceSpine :: Foldable f => f a -> ()-  -- forceSpine xs-  --   | Solo r <- traverse_ Solo xs-  --   = r-  Solo f <*> Solo x = Solo (f x)-  liftA2 f (Solo x) (Solo y) = Solo (f x y)---- | For tuples, the 'Monoid' constraint on @a@ determines--- how the first values merge.--- For example, 'String's concatenate:------ > ("hello ", (+15)) <*> ("world!", 2002)--- > ("hello world!",2017)------ @since 2.01-instance Monoid a => Applicative ((,) a) where-    pure x = (mempty, x)-    (u, f) <*> (v, x) = (u <> v, f x)-    liftA2 f (u, x) (v, y) = (u <> v, f x y)---- | @since 4.15-instance Monad Solo where-  Solo x >>= f = f x---- | @since 4.9.0.0-instance Monoid a => Monad ((,) a) where-    (u, a) >>= k = case k a of (v, b) -> (u <> v, b)---- | @since 4.14.0.0-instance Functor ((,,) a b) where-    fmap f (a, b, c) = (a, b, f c)---- | @since 4.14.0.0-instance (Monoid a, Monoid b) => Applicative ((,,) a b) where-    pure x = (mempty, mempty, x)-    (a, b, f) <*> (a', b', x) = (a <> a', b <> b', f x)---- | @since 4.14.0.0-instance (Monoid a, Monoid b) => Monad ((,,) a b) where-    (u, v, a) >>= k = case k a of (u', v', b) -> (u <> u', v <> v', b)---- | @since 4.14.0.0-instance Functor ((,,,) a b c) where-    fmap f (a, b, c, d) = (a, b, c, f d)---- | @since 4.14.0.0-instance (Monoid a, Monoid b, Monoid c) => Applicative ((,,,) a b c) where-    pure x = (mempty, mempty, mempty, x)-    (a, b, c, f) <*> (a', b', c', x) = (a <> a', b <> b', c <> c', f x)---- | @since 4.14.0.0-instance (Monoid a, Monoid b, Monoid c) => Monad ((,,,) a b c) where-    (u, v, w, a) >>= k = case k a of (u', v', w', b) -> (u <> u', v <> v', w <> w', b)---- | @since 4.10.0.0-instance Semigroup a => Semigroup (IO a) where-    (<>) = liftA2 (<>)---- | @since 4.9.0.0-instance Monoid a => Monoid (IO a) where-    mempty = pure mempty--{- | A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@-lets you apply any function from @(a -> b)@ to turn an @f a@ into an @f b@, preserving the-structure of @f@. Furthermore @f@ needs to adhere to the following:--[Identity]    @'fmap' 'id' == 'id'@-[Composition] @'fmap' (f . g) == 'fmap' f . 'fmap' g@--Note, that the second law follows from the free theorem of the type 'fmap' and-the first law, so you need only check that the former condition holds.--}--class Functor f where-    -- | 'fmap' is used to apply a function of type @(a -> b)@ to a value of type @f a@,-    -- where f is a functor, to produce a value of type @f b@.-    -- Note that for any type constructor with more than one parameter (e.g., `Either`),-    -- only the last type parameter can be modified with `fmap` (e.g., `b` in `Either a b`).-    ---    -- Some type constructors with two parameters or more have a @'Data.Bifunctor'@ instance that allows-    -- both the last and the penultimate parameters to be mapped over.-    ---    -- ==== __Examples__-    ---    -- Convert from a @'Data.Maybe.Maybe' Int@ to a @Maybe String@-    -- using 'Prelude.show':-    ---    -- >>> fmap show Nothing-    -- Nothing-    -- >>> fmap show (Just 3)-    -- Just "3"-    ---    -- Convert from an @'Data.Either.Either' Int Int@ to an-    -- @Either Int String@ using 'Prelude.show':-    ---    -- >>> fmap show (Left 17)-    -- Left 17-    -- >>> fmap show (Right 17)-    -- Right "17"-    ---    -- Double each element of a list:-    ---    -- >>> fmap (*2) [1,2,3]-    -- [2,4,6]-    ---    -- Apply 'Prelude.even' to the second element of a pair:-    ---    -- >>> fmap even (2,2)-    -- (2,True)-    ---    -- It may seem surprising that the function is only applied to the last element of the tuple-    -- compared to the list example above which applies it to every element in the list.-    -- To understand, remember that tuples are type constructors with multiple type parameters:-    -- a tuple of 3 elements @(a,b,c)@ can also be written @(,,) a b c@ and its @Functor@ instance-    -- is defined for @Functor ((,,) a b)@ (i.e., only the third parameter is free to be mapped over-    -- with @fmap@).-    ---    -- It explains why @fmap@ can be used with tuples containing values of different types as in the-    -- following example:-    ---    -- >>> fmap even ("hello", 1.0, 4)-    -- ("hello",1.0,True)--    fmap        :: (a -> b) -> f a -> f b--    -- | Replace all locations in the input with the same value.-    -- The default definition is @'fmap' . 'const'@, but this may be-    -- overridden with a more efficient version.-    ---    (<$)        :: a -> f b -> f a-    (<$)        =  fmap . const---- | A functor with application, providing operations to------ * embed pure expressions ('pure'), and------ * sequence computations and combine their results ('<*>' and 'liftA2').------ A minimal complete definition must include implementations of 'pure'--- and of either '<*>' or 'liftA2'. If it defines both, then they must behave--- the same as their default definitions:------      @('<*>') = 'liftA2' 'id'@------      @'liftA2' f x y = f 'Prelude.<$>' x '<*>' y@------ Further, any definition must satisfy the following:------ [Identity]------      @'pure' 'id' '<*>' v = v@------ [Composition]------      @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@------ [Homomorphism]------      @'pure' f '<*>' 'pure' x = 'pure' (f x)@------ [Interchange]------      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@--------- The other methods have the following default definitions, which may--- be overridden with equivalent specialized implementations:------   * @u '*>' v = ('id' '<$' u) '<*>' v@------   * @u '<*' v = 'liftA2' 'const' u v@------ As a consequence of these laws, the 'Functor' instance for @f@ will satisfy------   * @'fmap' f x = 'pure' f '<*>' x@--------- It may be useful to note that supposing------      @forall x y. p (q x y) = f x . g y@------ it follows from the above that------      @'liftA2' p ('liftA2' q u v) = 'liftA2' f u . 'liftA2' g v@--------- If @f@ is also a 'Monad', it should satisfy------   * @'pure' = 'return'@------   * @m1 '<*>' m2 = m1 '>>=' (\x1 -> m2 '>>=' (\x2 -> 'return' (x1 x2)))@------   * @('*>') = ('>>')@------ (which implies that 'pure' and '<*>' satisfy the applicative functor laws).--class Functor f => Applicative f where-    {-# MINIMAL pure, ((<*>) | liftA2) #-}-    -- | Lift a value.-    pure :: a -> f a--    -- | Sequential application.-    ---    -- A few functors support an implementation of '<*>' that is more-    -- efficient than the default one.-    ---    -- ==== __Example__-    -- Used in combination with @('<$>')@, @('<*>')@ can be used to build a record.-    ---    -- >>> data MyState = MyState {arg1 :: Foo, arg2 :: Bar, arg3 :: Baz}-    ---    -- >>> produceFoo :: Applicative f => f Foo-    ---    -- >>> produceBar :: Applicative f => f Bar-    -- >>> produceBaz :: Applicative f => f Baz-    ---    -- >>> mkState :: Applicative f => f MyState-    -- >>> mkState = MyState <$> produceFoo <*> produceBar <*> produceBaz-    (<*>) :: f (a -> b) -> f a -> f b-    (<*>) = liftA2 id--    -- | Lift a binary function to actions.-    ---    -- Some functors support an implementation of 'liftA2' that is more-    -- efficient than the default one. In particular, if 'fmap' is an-    -- expensive operation, it is likely better to use 'liftA2' than to-    -- 'fmap' over the structure and then use '<*>'.-    ---    -- This became a typeclass method in 4.10.0.0. Prior to that, it was-    -- a function defined in terms of '<*>' and 'fmap'.-    ---    -- ==== __Example__-    -- >>> liftA2 (,) (Just 3) (Just 5)-    -- Just (3,5)--    liftA2 :: (a -> b -> c) -> f a -> f b -> f c-    liftA2 f x = (<*>) (fmap f x)--    -- | Sequence actions, discarding the value of the first argument.-    ---    -- ==== __Examples__-    -- If used in conjunction with the Applicative instance for 'Maybe',-    -- you can chain Maybe computations, with a possible "early return"-    -- in case of 'Nothing'.-    ---    -- >>> Just 2 *> Just 3-    -- Just 3-    ---    -- >>> Nothing *> Just 3-    -- Nothing-    ---    -- Of course a more interesting use case would be to have effectful-    -- computations instead of just returning pure values.-    ---    -- >>> import Data.Char-    -- >>> import Text.ParserCombinators.ReadP-    -- >>> let p = string "my name is " *> munch1 isAlpha <* eof-    -- >>> readP_to_S p "my name is Simon"-    -- [("Simon","")]--    (*>) :: f a -> f b -> f b-    a1 *> a2 = (id <$ a1) <*> a2--    -- This is essentially the same as liftA2 (flip const), but if the-    -- Functor instance has an optimized (<$), it may be better to use-    -- that instead. Before liftA2 became a method, this definition-    -- was strictly better, but now it depends on the functor. For a-    -- functor supporting a sharing-enhancing (<$), this definition-    -- may reduce allocation by preventing a1 from ever being fully-    -- realized. In an implementation with a boring (<$) but an optimizing-    -- liftA2, it would likely be better to define (*>) using liftA2.--    -- | Sequence actions, discarding the value of the second argument.-    ---    (<*) :: f a -> f b -> f a-    (<*) = liftA2 const---- | A variant of '<*>' with the arguments reversed.----(<**>) :: Applicative f => f a -> f (a -> b) -> f b-(<**>) = liftA2 (\a f -> f a)--- Don't use $ here, see the note at the top of the page---- | Lift a function to actions.--- Equivalent to Functor's `fmap` but implemented using only `Applicative`'s methods:--- `liftA f a = pure f <*> a`------ As such this function may be used to implement a `Functor` instance from an `Applicative` one.------- ==== __Examples__--- Using the Applicative instance for Lists:------ >>> liftA (+1) [1, 2]--- [2,3]------ Or the Applicative instance for 'Maybe'------ >>> liftA (+1) (Just 3)--- Just 4--liftA :: Applicative f => (a -> b) -> f a -> f b-liftA f a = pure f <*> a--- Caution: since this may be used for `fmap`, we can't use the obvious--- definition of liftA = fmap.---- | Lift a ternary function to actions.--liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d-liftA3 f a b c = liftA2 f a b <*> c---{-# INLINABLE liftA #-}-{-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-}-{-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-}-{-# INLINABLE liftA3 #-}-{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}-{-# SPECIALISE liftA3 :: (a1->a2->a3->r) ->-                                Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}---- | The 'join' function is the conventional monad join operator. It--- is used to remove one level of monadic structure, projecting its--- bound argument into the outer level.--------- \'@'join' bss@\' can be understood as the @do@ expression------ @--- do bs <- bss---    bs--- @------ ==== __Examples__------ A common use of 'join' is to run an 'IO' computation returned from--- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions--- can't perform 'IO' directly. Recall that------ @--- 'GHC.Conc.atomically' :: STM a -> IO a--- @------ is used to run 'GHC.Conc.STM' transactions atomically. So, by--- specializing the types of 'GHC.Conc.atomically' and 'join' to------ @--- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b)--- 'join'       :: IO (IO b)  -> IO b--- @------ we can compose them as------ @--- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b--- @------ to run an 'GHC.Conc.STM' transaction and the 'IO' action it--- returns.-join              :: (Monad m) => m (m a) -> m a-join x            =  x >>= id--{- | The 'Monad' class defines the basic operations over a /monad/,-a concept from a branch of mathematics known as /category theory/.-From the perspective of a Haskell programmer, however, it is best to-think of a monad as an /abstract datatype/ of actions.-Haskell's @do@ expressions provide a convenient syntax for writing-monadic expressions.--Instances of 'Monad' should satisfy the following:--[Left identity]  @'return' a '>>=' k  =  k a@-[Right identity] @m '>>=' 'return'  =  m@-[Associativity]  @m '>>=' (\\x -> k x '>>=' h)  =  (m '>>=' k) '>>=' h@--Furthermore, the 'Monad' and 'Applicative' operations should relate as follows:--* @'pure' = 'return'@-* @m1 '<*>' m2 = m1 '>>=' (\x1 -> m2 '>>=' (\x2 -> 'return' (x1 x2)))@--The above laws imply:--* @'fmap' f xs  =  xs '>>=' 'return' . f@-* @('>>') = ('*>')@--and that 'pure' and ('<*>') satisfy the applicative functor laws.--The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'-defined in the "Prelude" satisfy these laws.--}-class Applicative m => Monad m where-    -- | Sequentially compose two actions, passing any value produced-    -- by the first as an argument to the second.-    ---    -- \'@as '>>=' bs@\' can be understood as the @do@ expression-    ---    -- @-    -- do a <- as-    --    bs a-    -- @-    (>>=)       :: forall a b. m a -> (a -> m b) -> m b--    -- | Sequentially compose two actions, discarding any value produced-    -- by the first, like sequencing operators (such as the semicolon)-    -- in imperative languages.-    ---    -- \'@as '>>' bs@\' can be understood as the @do@ expression-    ---    -- @-    -- do as-    --    bs-    -- @-    (>>)        :: forall a b. m a -> m b -> m b-    m >> k = m >>= \_ -> k -- See Note [Recursive bindings for Applicative/Monad]-    {-# INLINE (>>) #-}--    -- | Inject a value into the monadic type.-    return      :: a -> m a-    return      = pure--{- Note [Recursive bindings for Applicative/Monad]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The original Applicative/Monad proposal stated that after-implementation, the designated implementation of (>>) would become--  (>>) :: forall a b. m a -> m b -> m b-  (>>) = (*>)--by default. You might be inclined to change this to reflect the stated-proposal, but you really shouldn't! Why? Because people tend to define-such instances the /other/ way around: in particular, it is perfectly-legitimate to define an instance of Applicative (*>) in terms of (>>),-which would lead to an infinite loop for the default implementation of-Monad! And people do this in the wild.--This turned into a nasty bug that was tricky to track down, and rather-than eliminate it everywhere upstream, it's easier to just retain the-original default.---}---- | Same as '>>=', but with the arguments interchanged.-{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}-(=<<)           :: Monad m => (a -> m b) -> m a -> m b-f =<< x         = x >>= f---- | Conditional execution of 'Applicative' expressions. For example,------ > when debug (putStrLn "Debugging")------ will output the string @Debugging@ if the Boolean value @debug@--- is 'True', and otherwise do nothing.-when      :: (Applicative f) => Bool -> f () -> f ()-{-# INLINABLE when #-}-{-# SPECIALISE when :: Bool -> IO () -> IO () #-}-{-# SPECIALISE when :: Bool -> Maybe () -> Maybe () #-}-when p s  = if p then s else pure ()---- | Evaluate each action in the sequence from left to right,--- and collect the results.-sequence :: Monad m => [m a] -> m [a]-{-# INLINE sequence #-}-sequence = mapM id--- Note: [sequence and mapM]---- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@.-mapM :: Monad m => (a -> m b) -> [a] -> m [b]-{-# INLINE mapM #-}-mapM f as = foldr k (return []) as-            where-              k a r = do { x <- f a; xs <- r; return (x:xs) }--{--Note: [sequence and mapM]-~~~~~~~~~~~~~~~~~~~~~~~~~-Originally, we defined--mapM f = sequence . map f--This relied on list fusion to produce efficient code for mapM, and led to-excessive allocation in cryptarithm2. Defining--sequence = mapM id--relies only on inlining a tiny function (id) and beta reduction, which tends to-be a more reliable aspect of simplification. Indeed, this does not lead to-similar problems in nofib.--}---- | Promote a function to a monad.-liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r-liftM f m1              = do { x1 <- m1; return (f x1) }---- | Promote a function to a monad, scanning the monadic arguments from--- left to right.  For example,------ > liftM2 (+) [0,1] [0,2] = [0,2,1,3]--- > liftM2 (+) (Just 1) Nothing = Nothing----liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r-liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }--- Caution: since this may be used for `liftA2`, we can't use the obvious--- definition of liftM2 = liftA2.---- | Promote a function to a monad, scanning the monadic arguments from--- left to right (cf. 'liftM2').-liftM3  :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r-liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }---- | Promote a function to a monad, scanning the monadic arguments from--- left to right (cf. 'liftM2').-liftM4  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r-liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }---- | Promote a function to a monad, scanning the monadic arguments from--- left to right (cf. 'liftM2').-liftM5  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r-liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }--{-# INLINABLE liftM #-}-{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-}-{-# SPECIALISE liftM :: (a1->r) -> Maybe a1 -> Maybe r #-}-{-# INLINABLE liftM2 #-}-{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}-{-# SPECIALISE liftM2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}-{-# INLINABLE liftM3 #-}-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}-{-# INLINABLE liftM4 #-}-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-}-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe r #-}-{-# INLINABLE liftM5 #-}-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-}-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe a5 -> Maybe r #-}--{- | In many situations, the 'liftM' operations can be replaced by uses of-'ap', which promotes function application.--> return f `ap` x1 `ap` ... `ap` xn--is equivalent to--> liftMn f x1 x2 ... xn---}--ap                :: (Monad m) => m (a -> b) -> m a -> m b-ap m1 m2          = do { x1 <- m1; x2 <- m2; return (x1 x2) }--- Since many Applicative instances define (<*>) = ap, we--- cannot define ap = (<*>)-{-# INLINABLE ap #-}-{-# SPECIALISE ap :: IO (a -> b) -> IO a -> IO b #-}-{-# SPECIALISE ap :: Maybe (a -> b) -> Maybe a -> Maybe b #-}---- instances for Prelude types---- | @since 2.01-instance Functor ((->) r) where-    fmap = (.)---- | @since 2.01-instance Applicative ((->) r) where-    pure = const-    (<*>) f g x = f x (g x)-    liftA2 q f g x = q (f x) (g x)---- | @since 2.01-instance Monad ((->) r) where-    f >>= k = \ r -> k (f r) r---- | @since 4.15-instance Functor Solo where-  fmap f (Solo a) = Solo (f a)--  -- Being strict in the `Solo` argument here seems most consistent-  -- with the concept behind `Solo`: always strict in the wrapper and lazy-  -- in the contents.-  x <$ Solo _ = Solo x---- | @since 2.01-instance Functor ((,) a) where-    fmap f (x,y) = (x, f y)---- | @since 2.01-instance  Functor Maybe  where-    fmap _ Nothing       = Nothing-    fmap f (Just a)      = Just (f a)---- | @since 2.01-instance Applicative Maybe where-    pure = Just--    Just f  <*> m       = fmap f m-    Nothing <*> _m      = Nothing--    liftA2 f (Just x) (Just y) = Just (f x y)-    liftA2 _ _ _ = Nothing--    Just _m1 *> m2      = m2-    Nothing  *> _m2     = Nothing---- | @since 2.01-instance  Monad Maybe  where-    (Just x) >>= k      = k x-    Nothing  >>= _      = Nothing--    (>>) = (*>)---- -------------------------------------------------------------------------------- The Alternative class definition--infixl 3 <|>---- | A monoid on applicative functors.------ If defined, 'some' and 'many' should be the least solutions--- of the equations:------ * @'some' v = (:) 'Prelude.<$>' v '<*>' 'many' v@------ * @'many' v = 'some' v '<|>' 'pure' []@-class Applicative f => Alternative f where-    -- | The identity of '<|>'-    empty :: f a-    -- | An associative binary operation-    (<|>) :: f a -> f a -> f a--    -- | One or more.-    some :: f a -> f [a]-    some v = some_v-      where-        many_v = some_v <|> pure []-        some_v = liftA2 (:) v many_v--    -- | Zero or more.-    many :: f a -> f [a]-    many v = many_v-      where-        many_v = some_v <|> pure []-        some_v = liftA2 (:) v many_v----- | @since 2.01-instance Alternative Maybe where-    empty = Nothing-    Nothing <|> r = r-    l       <|> _ = l---- -------------------------------------------------------------------------------- The MonadPlus class definition---- | Monads that also support choice and failure.-class (Alternative m, Monad m) => MonadPlus m where-   -- | The identity of 'mplus'.  It should also satisfy the equations-   ---   -- > mzero >>= f  =  mzero-   -- > v >> mzero   =  mzero-   ---   -- The default definition is-   ---   -- @-   -- mzero = 'empty'-   -- @-   mzero :: m a-   mzero = empty--   -- | An associative operation. The default definition is-   ---   -- @-   -- mplus = ('<|>')-   -- @-   mplus :: m a -> m a -> m a-   mplus = (<|>)---- | @since 2.01-instance MonadPlus Maybe-------------------------------------------------- The non-empty list type--infixr 5 :|---- | Non-empty (and non-strict) list type.------ @since 4.9.0.0-data NonEmpty a = a :| [a]-  deriving ( Eq  -- ^ @since 4.9.0.0-           , Ord -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Functor NonEmpty where-  fmap f ~(a :| as) = f a :| fmap f as-  b <$ ~(_ :| as)   = b   :| (b <$ as)---- | @since 4.9.0.0-instance Applicative NonEmpty where-  pure a = a :| []-  (<*>) = ap-  liftA2 = liftM2---- | @since 4.9.0.0-instance Monad NonEmpty where-  ~(a :| as) >>= f = b :| (bs ++ bs')-    where b :| bs = f a-          bs' = as >>= toList . f-          toList ~(c :| cs) = c : cs--------------------------------------------------- The list type---- | @since 2.01-instance Functor [] where-    {-# INLINE fmap #-}-    fmap = map---- See Note: [List comprehensions and inlining]--- | @since 2.01-instance Applicative [] where-    {-# INLINE pure #-}-    pure x    = [x]-    {-# INLINE (<*>) #-}-    fs <*> xs = [f x | f <- fs, x <- xs]-    {-# INLINE liftA2 #-}-    liftA2 f xs ys = [f x y | x <- xs, y <- ys]-    {-# INLINE (*>) #-}-    xs *> ys  = [y | _ <- xs, y <- ys]---- See Note: [List comprehensions and inlining]--- | @since 2.01-instance Monad []  where-    {-# INLINE (>>=) #-}-    xs >>= f             = [y | x <- xs, y <- f x]-    {-# INLINE (>>) #-}-    (>>) = (*>)---- | @since 2.01-instance Alternative [] where-    empty = []-    (<|>) = (++)---- | @since 2.01-instance MonadPlus []--{--A few list functions that appear here because they are used here.-The rest of the prelude list functions are in GHC.List.--}---------------------------------------------------      foldr/build/augment--------------------------------------------------- | 'foldr', 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)...)--foldr            :: (a -> b -> b) -> b -> [a] -> b--- foldr _ z []     =  z--- foldr f z (x:xs) =  f x (foldr f z xs)-{-# INLINE [0] foldr #-}--- Inline only in the final stage, after the foldr/cons rule has had a chance--- Also note that we inline it when it has *two* parameters, which are the--- ones we are keen about specialising!-foldr k z = go-          where-            go []     = z-            go (y:ys) = y `k` go ys---- | A list producer that can be fused with 'foldr'.--- This function is merely------ >    build g = g (:) []------ but GHC's simplifier will transform an expression of the form--- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@,--- which avoids producing an intermediate list.--build   :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]-{-# INLINE [1] build #-}-        -- The INLINE is important, even though build is tiny,-        -- because it prevents [] getting inlined in the version that-        -- appears in the interface file.  If [] *is* inlined, it-        -- won't match with [] appearing in rules in an importing module.-        ---        -- The "1" says to inline in phase 1--build g = g (:) []---- | A list producer that can be fused with 'foldr'.--- This function is merely------ >    augment g xs = g (:) xs------ but GHC's simplifier will transform an expression of the form--- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to--- @g k ('foldr' k z xs)@, which avoids producing an intermediate list.--augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]-{-# INLINE [1] augment #-}-augment g xs = g (:) xs--{-# RULES-"fold/build"    forall k z (g::forall b. (a->b->b) -> b -> b) .-                foldr k z (build g) = g k z--"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .-                foldr k z (augment g xs) = g k (foldr k z xs)--"foldr/id"                        foldr (:) [] = \x  -> x-"foldr/app"     [1] forall ys. foldr (:) ys = \xs -> xs ++ ys-        -- Only activate this from phase 1, because that's-        -- when we disable the rule that expands (++) into foldr---- The foldr/cons rule looks nice, but it can give disastrously--- bloated code when commpiling---      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]--- i.e. when there are very very long literal lists--- So I've disabled it for now. We could have special cases--- for short lists, I suppose.--- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)--"foldr/single"  forall k z x. foldr k z [x] = k x z-"foldr/nil"     forall k z.   foldr k z []  = z--"foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .-                           foldr k z (x:build g) = k x (g k z)--"augment/build" forall (g::forall b. (a->b->b) -> b -> b)-                       (h::forall b. (a->b->b) -> b -> b) .-                       augment g (build h) = build (\c n -> g c (h c n))-"augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .-                        augment g [] = build g- #-}---- This rule is true, but not (I think) useful:---      augment g (augment h t) = augment (\cn -> g c (h c n)) t---------------------------------------------------              map--------------------------------------------------- | \(\mathcal{O}(n)\). 'map' @f xs@ is the list obtained by applying @f@ to--- each element of @xs@, i.e.,------ > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]--- > map f [x1, x2, ...] == [f x1, f x2, ...]------ >>> map (+1) [1, 2, 3]--- [2,3,4]-map :: (a -> b) -> [a] -> [b]-{-# 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---- Note eta expanded-mapFB ::  (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst-{-# INLINE [0] mapFB #-} -- See Note [Inline FB functions] in GHC.List-mapFB c f = \x ys -> c (f x) ys--{- Note [The rules for map]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-The rules for map work like this.--* Up to (but not including) phase 1, we use the "map" rule to-  rewrite all saturated applications of map with its build/fold-  form, hoping for fusion to happen.--  In phase 1 and 0, we switch off that rule, inline build, and-  switch on the "mapList" rule, which rewrites the foldr/mapFB-  thing back into plain map.--  It's important that these two rules aren't both active at once-  (along with build's unfolding) else we'd get an infinite loop-  in the rules.  Hence the activation control below.--* This same pattern is followed by many other functions:-  e.g. append, filter, iterate, repeat, etc. in GHC.List--  See also Note [Inline FB functions] in GHC.List--* The "mapFB" rule optimises compositions of map--* The "mapFB/id" rule gets rid of 'map id' calls.-  You might think that (mapFB c id) will turn into c simply-  when mapFB is inlined; but before that happens the "mapList"-  rule turns-     (foldr (mapFB (:) id) [] a-  back into-     map id-  Which is not very clever.--* Any similarity to the Functor laws for [] is expected.--}--{-# RULES-"map"       [~1] forall f xs.   map f xs                = build (\c n -> foldr (mapFB c f) n xs)-"mapList"   [1]  forall f.      foldr (mapFB (:) f) []  = map f-"mapFB"     forall c f g.       mapFB (mapFB c f) g     = mapFB c (f.g)-"mapFB/id"  forall c.           mapFB c (\x -> x)       = c-  #-}---- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost--- Coercions for Haskell", section 6.5:---   http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf--{-# RULES "map/coerce" [1] map coerce = coerce #-}--- See Note [Getting the map/coerce RULE to work] in CoreOpt---------------------------------------------------              append--------------------------------------------------- | Append two lists, i.e.,------ > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn]--- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...]------ If the first list is not finite, the result is the first list.--(++) :: [a] -> [a] -> [a]-{-# NOINLINE [1] (++) #-}    -- We want the RULE to fire first.-                             -- It's recursive, so won't inline anyway,-                             -- but saying so is more explicit-(++) []     ys = ys-(++) (x:xs) ys = x : xs ++ ys--{-# RULES-"++"    [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys-  #-}----- |'otherwise' is defined as the value 'True'.  It helps to make--- guards more readable.  eg.------ >  f x | x < 0     = ...--- >      | otherwise = ...-otherwise               :: Bool-otherwise               =  True--------------------------------------------------- Type Char and String--------------------------------------------------- | A 'String' is a list of characters.  String constants in Haskell are values--- of type 'String'.------ See "Data.List" for operations on lists.-type String = [Char]--unsafeChr :: Int -> Char-unsafeChr (I# i#) = C# (chr# i#)---- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.-ord :: Char -> Int-ord (C# c#) = I# (ord# c#)---- | This 'String' equality predicate is used when desugaring--- pattern-matches against strings.-eqString :: String -> String -> Bool-eqString []       []       = True-eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2-eqString _        _        = False--{-# RULES "eqString" (==) = eqString #-}--- eqString also has a BuiltInRule in GHC.Core.Opt.ConstantFold:---      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2---------------------------------------------------- 'Int' related definitions-------------------------------------------------maxInt, minInt :: Int--{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -}-#if WORD_SIZE_IN_BITS == 31-minInt  = I# (-0x40000000#)-maxInt  = I# 0x3FFFFFFF#-#elif WORD_SIZE_IN_BITS == 32-minInt  = I# (-0x80000000#)-maxInt  = I# 0x7FFFFFFF#-#else-minInt  = I# (-0x8000000000000000#)-maxInt  = I# 0x7FFFFFFFFFFFFFFF#-#endif--------------------------------------------------- The function type--------------------------------------------------- | Identity function.------ > id x = x-id                      :: a -> a-id x                    =  x---- Assertion function.  This simply ignores its boolean argument.--- The compiler may rewrite it to @('assertError' line)@.---- | If the first argument evaluates to 'True', then the result is the--- second argument.  Otherwise an 'Control.Exception.AssertionFailed' exception--- is raised, containing a 'String' with the source file and line number of the--- call to 'assert'.------ Assertions can normally be turned on or off with a compiler flag--- (for GHC, assertions are normally on unless optimisation is turned on--- with @-O@ or the @-fignore-asserts@--- option is given).  When assertions are turned off, the first--- argument to 'assert' is ignored, and the second argument is--- returned as the result.----      SLPJ: in 5.04 etc 'assert' is in GHC.Prim,---      but from Template Haskell onwards it's simply---      defined here in Base.hs-assert :: Bool -> a -> a-assert _pred r = r--breakpoint :: a -> a-breakpoint r = r--breakpointCond :: Bool -> a -> a-breakpointCond _ r = r--data Opaque = forall a. O a--- | @const x@ is a unary function which evaluates to @x@ for all inputs.------ >>> const 42 "hello"--- 42------ >>> map (const 42) [0..3]--- [42,42,42,42]-const                   :: a -> b -> a-const x _               =  x---- | Function composition.-{-# INLINE (.) #-}--- Make sure it has TWO args only on the left, so that it inlines--- when applied to two functions, even if there is no final argument-(.)    :: (b -> c) -> (a -> b) -> a -> c-(.) f g = \x -> f (g x)---- | @'flip' f@ takes its (first) two arguments in the reverse order of @f@.------ >>> flip (++) "hello" "world"--- "worldhello"-flip                    :: (a -> b -> c) -> b -> a -> c-flip f x y              =  f y x---- | Application operator.  This operator is redundant, since ordinary--- application @(f x)@ means the same as @(f '$' x)@. However, '$' has--- low, right-associative binding precedence, so it sometimes allows--- parentheses to be omitted; for example:------ > f $ g $ h x  =  f (g (h x))------ It is also useful in higher-order situations, such as @'map' ('$' 0) xs@,--- or @'Data.List.zipWith' ('$') fs xs@.------ Note that @('$')@ is levity-polymorphic in its result type, so that--- @foo '$' True@ where @foo :: Bool -> Int#@ is well-typed.-{-# INLINE ($) #-}-($) :: forall r a (b :: TYPE r). (a -> b) -> a -> b-f $ x =  f x---- | Strict (call-by-value) application operator. It takes a function and an--- argument, evaluates the argument to weak head normal form (WHNF), then calls--- the function with that value.--($!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b-{-# INLINE ($!) #-}-f $! x = let !vx = x in f vx  -- see #2273---- | @'until' p f@ yields the result of applying @f@ until @p@ holds.-until                   :: (a -> Bool) -> (a -> a) -> a -> a-until p f = go-  where-    go x | p x          = x-         | otherwise    = go (f x)---- | 'asTypeOf' is a type-restricted version of 'const'.  It is usually--- used as an infix operator, and its typing forces its first argument--- (which is usually overloaded) to have the same type as the second.-asTypeOf                :: a -> a -> a-asTypeOf                =  const--------------------------------------------------- Functor/Applicative/Monad instances for IO--------------------------------------------------- | @since 2.01-instance  Functor IO where-   fmap f x = x >>= (pure . f)---- | @since 2.01-instance Applicative IO where-    {-# INLINE pure #-}-    {-# INLINE (*>) #-}-    {-# INLINE liftA2 #-}-    pure  = returnIO-    (*>)  = thenIO-    (<*>) = ap-    liftA2 = liftM2---- | @since 2.01-instance  Monad IO  where-    {-# INLINE (>>)   #-}-    {-# INLINE (>>=)  #-}-    (>>)      = (*>)-    (>>=)     = bindIO---- | @since 4.9.0.0-instance Alternative IO where-    empty = failIO "mzero"-    (<|>) = mplusIO---- | @since 4.9.0.0-instance MonadPlus IO--returnIO :: a -> IO a-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)--thenIO :: IO a -> IO b -> IO b-thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s)---- Note that it is import that we do not SOURCE import this as--- its demand signature encodes knowledge of its bottoming--- behavior, which can expose useful simplifications. See--- #16588.-failIO :: String -> IO a-failIO s = IO (raiseIO# (mkUserError s))--unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))-unIO (IO a) = a--{- |-Returns the tag of a constructor application; this function is used-by the deriving code for Eq, Ord and Enum.--}-{-# INLINE getTag #-}-getTag :: a -> Int#-getTag x = dataToTag# x--------------------------------------------------- Numeric primops--------------------------------------------------- Definitions of the boxed PrimOps; these will be--- used in the case of partial applications, etc.---- See Note [INLINE division wrappers]-{-# INLINE quotInt #-}-{-# INLINE remInt #-}-{-# INLINE divInt #-}-{-# INLINE modInt #-}-{-# INLINE quotRemInt #-}-{-# INLINE divModInt #-}--quotInt, remInt, divInt, modInt :: Int -> Int -> Int-(I# x) `quotInt`  (I# y) = I# (x `quotInt#` y)-(I# x) `remInt`   (I# y) = I# (x `remInt#`  y)-(I# x) `divInt`   (I# y) = I# (x `divInt#`  y)-(I# x) `modInt`   (I# y) = I# (x `modInt#`  y)--quotRemInt :: Int -> Int -> (Int, Int)-(I# x) `quotRemInt` (I# y) = case x `quotRemInt#` y of-                             (# q, r #) ->-                                 (I# q, I# r)--divModInt :: Int -> Int -> (Int, Int)-(I# x) `divModInt` (I# y) = case x `divModInt#` y of-                            (# q, r #) -> (I# q, I# r)--divModInt# :: Int# -> Int# -> (# Int#, Int# #)-x# `divModInt#` y#- | isTrue# (x# ># 0#) && isTrue# (y# <# 0#) =-                                    case (x# -# 1#) `quotRemInt#` y# of-                                      (# q, r #) -> (# q -# 1#, r +# y# +# 1# #)- | isTrue# (x# <# 0#) && isTrue# (y# ># 0#) =-                                    case (x# +# 1#) `quotRemInt#` y# of-                                      (# q, r #) -> (# q -# 1#, r +# y# -# 1# #)- | otherwise                                =-                                    x# `quotRemInt#` y#--{- Note [INLINE division wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Int division functions such as 'quotRemInt' and 'divModInt' have-been manually worker/wrappered, presumably because they construct-*nested* products.-We intend to preserve the exact worker/wrapper split, hence we mark-the wrappers INLINE (#19267). That makes sure the optimiser doesn't-accidentally inline the worker into the wrapper, undoing the manual-split again.--}---- Wrappers for the shift operations.  The uncheckedShift# family are--- undefined when the amount being shifted by is greater than the size--- in bits of Int#, so these wrappers perform a check and return--- either zero or -1 appropriately.------ Note that these wrappers still produce undefined results when the--- second argument (the shift amount) is negative.---- | Shift the argument left by the specified number of bits--- (which must be non-negative).-shiftL# :: Word# -> Int# -> Word#-a `shiftL#` b   | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0##-                | otherwise                          = a `uncheckedShiftL#` b---- | Shift the argument right by the specified number of bits--- (which must be non-negative).--- The "RL" means "right, logical" (as opposed to RA for arithmetic)--- (although an arithmetic right shift wouldn't make sense for Word#)-shiftRL# :: Word# -> Int# -> Word#-a `shiftRL#` b  | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0##-                | otherwise                          = a `uncheckedShiftRL#` b---- | Shift the argument left by the specified number of bits--- (which must be non-negative).-iShiftL# :: Int# -> Int# -> Int#-a `iShiftL#` b  | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0#-                | otherwise                          = a `uncheckedIShiftL#` b---- | Shift the argument right (signed) by the specified number of bits--- (which must be non-negative).--- The "RA" means "right, arithmetic" (as opposed to RL for logical)-iShiftRA# :: Int# -> Int# -> Int#-a `iShiftRA#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = if isTrue# (a <# 0#)-                                                          then (-1#)-                                                          else 0#-                | otherwise                          = a `uncheckedIShiftRA#` b---- | Shift the argument right (unsigned) by the specified number of bits--- (which must be non-negative).--- The "RL" means "right, logical" (as opposed to RA for arithmetic)-iShiftRL# :: Int# -> Int# -> Int#-a `iShiftRL#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0#-                | otherwise                          = a `uncheckedIShiftRL#` b---- Rules for C strings (the functions themselves are now in GHC.CString)-{-# RULES-"unpack"       [~1] forall a   . unpackCString# a             = build (unpackFoldrCString# a)-"unpack-list"  [1]  forall a   . unpackFoldrCString# a (:) [] = unpackCString# a-"unpack-append"     forall a n . unpackFoldrCString# a (:) n  = unpackAppendCString# a n--"unpack-utf8"       [~1] forall a   . unpackCStringUtf8# a             = build (unpackFoldrCStringUtf8# a)-"unpack-list-utf8"  [1]  forall a   . unpackFoldrCStringUtf8# a (:) [] = unpackCStringUtf8# a-"unpack-append-utf8"     forall a n . unpackFoldrCStringUtf8# a (:) n  = unpackAppendCStringUtf8# a n---- There's a built-in rule (in GHC.Core.Op.ConstantFold) for---      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n---- See also the Note [String literals in GHC] in CString.hs--  #-}
− GHC/Base.hs-boot 
@@ -1,9 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Base (Maybe, Semigroup, Monoid) where--import GHC.Maybe (Maybe)-import GHC.Types ()--class Semigroup a-class Monoid a
− GHC/Bits.hs 
@@ -1,719 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Bits--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ This module defines bitwise operations for signed and unsigned--- integers.  Instances of the class 'Bits' for the 'Int' and--- 'Integer' types are available from this module, and instances for--- explicitly sized integral types are available from the--- "Data.Int" and "Data.Word" modules.-----------------------------------------------------------------------------------module GHC.Bits (-  Bits(-    (.&.), (.|.), xor,-    complement,-    shift,-    rotate,-    zeroBits,-    bit,-    setBit,-    clearBit,-    complementBit,-    testBit,-    bitSizeMaybe,-    bitSize,-    isSigned,-    shiftL, shiftR,-    unsafeShiftL, unsafeShiftR,-    rotateL, rotateR,-    popCount-  ),-  FiniteBits(-    finiteBitSize,-    countLeadingZeros,-    countTrailingZeros-  ),--  bitDefault,-  testBitDefault,-  popCountDefault,-  toIntegralSized,- ) where---- Defines the @Bits@ class containing bit-based operations.--- See library document for details on the semantics of the--- individual operations.--#include "MachDeps.h"--import Data.Maybe-import GHC.Num-import GHC.Base-import GHC.Real--infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`-infixl 7 .&.-infixl 6 `xor`-infixl 5 .|.--{-# DEPRECATED bitSize "Use 'bitSizeMaybe' or 'finiteBitSize' instead" #-} -- deprecated in 7.8---- | The 'Bits' class defines bitwise operations over integral types.------ * Bits are numbered from 0 with bit 0 being the least---   significant bit.-class Eq a => Bits a where-    {-# MINIMAL (.&.), (.|.), xor, complement,-                (shift | (shiftL, shiftR)),-                (rotate | (rotateL, rotateR)),-                bitSize, bitSizeMaybe, isSigned, testBit, bit, popCount #-}--    -- | Bitwise \"and\"-    (.&.) :: a -> a -> a--    -- | Bitwise \"or\"-    (.|.) :: a -> a -> a--    -- | Bitwise \"xor\"-    xor :: a -> a -> a--    {-| Reverse all the bits in the argument -}-    complement        :: a -> a--    {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive,-        or right by @-i@ bits otherwise.-        Right shifts perform sign extension on signed number types;-        i.e. they fill the top bits with 1 if the @x@ is negative-        and with 0 otherwise.--        An instance can define either this unified 'shift' or 'shiftL' and-        'shiftR', depending on which is more convenient for the type in-        question. -}-    shift             :: a -> Int -> a--    x `shift`   i | i<0       = x `shiftR` (-i)-                  | i>0       = x `shiftL` i-                  | otherwise = x--    {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive,-        or right by @-i@ bits otherwise.--        For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.--        An instance can define either this unified 'rotate' or 'rotateL' and-        'rotateR', depending on which is more convenient for the type in-        question. -}-    rotate            :: a -> Int -> a--    x `rotate`  i | i<0       = x `rotateR` (-i)-                  | i>0       = x `rotateL` i-                  | otherwise = x--    {--    -- Rotation can be implemented in terms of two shifts, but care is-    -- needed for negative values.  This suggested implementation assumes-    -- 2's-complement arithmetic.  It is commented out because it would-    -- require an extra context (Ord a) on the signature of 'rotate'.-    x `rotate`  i | i<0 && isSigned x && x<0-                         = let left = i+bitSize x in-                           ((x `shift` i) .&. complement ((-1) `shift` left))-                           .|. (x `shift` left)-                  | i<0  = (x `shift` i) .|. (x `shift` (i+bitSize x))-                  | i==0 = x-                  | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))-    -}--    -- | 'zeroBits' is the value with all bits unset.-    ---    -- The following laws ought to hold (for all valid bit indices @/n/@):-    ---    --   * @'clearBit' 'zeroBits' /n/ == 'zeroBits'@-    --   * @'setBit'   'zeroBits' /n/ == 'bit' /n/@-    --   * @'testBit'  'zeroBits' /n/ == False@-    --   * @'popCount' 'zeroBits'   == 0@-    ---    -- This method uses @'clearBit' ('bit' 0) 0@ as its default-    -- implementation (which ought to be equivalent to 'zeroBits' for-    -- types which possess a 0th bit).-    ---    -- @since 4.7.0.0-    zeroBits :: a-    zeroBits = clearBit (bit 0) 0--    -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear.-    ---    -- Can be implemented using `bitDefault' if @a@ is also an-    -- instance of 'Num'.-    ---    -- See also 'zeroBits'.-    bit               :: Int -> a--    -- | @x \`setBit\` i@ is the same as @x .|. bit i@-    setBit            :: a -> Int -> a--    -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@-    clearBit          :: a -> Int -> a--    -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@-    complementBit     :: a -> Int -> a--    {-| @x \`testBit\` i@ is the same as @x .&. bit n /= 0@--        In other words it returns True if the bit at offset @n-        is set.--        Can be implemented using `testBitDefault' if @a@ is also an-        instance of 'Num'.-        -}-    testBit           :: a -> Int -> Bool--    {-| Return the number of bits in the type of the argument.  The actual-        value of the argument is ignored.  Returns Nothing-        for types that do not have a fixed bitsize, like 'Integer'.--        @since 4.7.0.0-        -}-    bitSizeMaybe      :: a -> Maybe Int--    {-| Return the number of bits in the type of the argument.  The actual-        value of the argument is ignored.  The function 'bitSize' is-        undefined for types that do not have a fixed bitsize, like 'Integer'.--        Default implementation based upon 'bitSizeMaybe' provided since-        4.12.0.0.-        -}-    bitSize           :: a -> Int-    bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b)--    {-| Return 'True' if the argument is a signed type.  The actual-        value of the argument is ignored -}-    isSigned          :: a -> Bool--    {-# INLINE setBit #-}-    {-# INLINE clearBit #-}-    {-# INLINE complementBit #-}-    x `setBit` i        = x .|. bit i-    x `clearBit` i      = x .&. complement (bit i)-    x `complementBit` i = x `xor` bit i--    {-| Shift the argument left by the specified number of bits-        (which must be non-negative). Some instances may throw an-        'Control.Exception.Overflow' exception if given a negative input.--        An instance can define either this and 'shiftR' or the unified-        'shift', depending on which is more convenient for the type in-        question. -}-    shiftL            :: a -> Int -> a-    {-# INLINE shiftL #-}-    x `shiftL`  i = x `shift`  i--    {-| Shift the argument left by the specified number of bits.  The-        result is undefined for negative shift amounts and shift amounts-        greater or equal to the 'bitSize'.--        Defaults to 'shiftL' unless defined explicitly by an instance.--        @since 4.5.0.0 -}-    unsafeShiftL            :: a -> Int -> a-    {-# INLINE unsafeShiftL #-}-    x `unsafeShiftL` i = x `shiftL` i--    {-| Shift the first argument right by the specified number of bits. The-        result is undefined for negative shift amounts and shift amounts-        greater or equal to the 'bitSize'. Some instances may throw an-        'Control.Exception.Overflow' exception if given a negative input.--        Right shifts perform sign extension on signed number types;-        i.e. they fill the top bits with 1 if the @x@ is negative-        and with 0 otherwise.--        An instance can define either this and 'shiftL' or the unified-        'shift', depending on which is more convenient for the type in-        question. -}-    shiftR            :: a -> Int -> a-    {-# INLINE shiftR #-}-    x `shiftR`  i = x `shift`  (-i)--    {-| Shift the first argument right by the specified number of bits, which-        must be non-negative and smaller than the number of bits in the type.--        Right shifts perform sign extension on signed number types;-        i.e. they fill the top bits with 1 if the @x@ is negative-        and with 0 otherwise.--        Defaults to 'shiftR' unless defined explicitly by an instance.--        @since 4.5.0.0 -}-    unsafeShiftR            :: a -> Int -> a-    {-# INLINE unsafeShiftR #-}-    x `unsafeShiftR` i = x `shiftR` i--    {-| Rotate the argument left by the specified number of bits-        (which must be non-negative).--        An instance can define either this and 'rotateR' or the unified-        'rotate', depending on which is more convenient for the type in-        question. -}-    rotateL           :: a -> Int -> a-    {-# INLINE rotateL #-}-    x `rotateL` i = x `rotate` i--    {-| Rotate the argument right by the specified number of bits-        (which must be non-negative).--        An instance can define either this and 'rotateL' or the unified-        'rotate', depending on which is more convenient for the type in-        question. -}-    rotateR           :: a -> Int -> a-    {-# INLINE rotateR #-}-    x `rotateR` i = x `rotate` (-i)--    {-| Return the number of set bits in the argument.  This number is-        known as the population count or the Hamming weight.--        Can be implemented using `popCountDefault' if @a@ is also an-        instance of 'Num'.--        @since 4.5.0.0 -}-    popCount          :: a -> Int---- |The 'FiniteBits' class denotes types with a finite, fixed number of bits.------ @since 4.7.0.0-class Bits b => FiniteBits b where-    -- | Return the number of bits in the type of the argument.-    -- The actual value of the argument is ignored. Moreover, 'finiteBitSize'-    -- is total, in contrast to the deprecated 'bitSize' function it replaces.-    ---    -- @-    -- 'finiteBitSize' = 'bitSize'-    -- 'bitSizeMaybe' = 'Just' . 'finiteBitSize'-    -- @-    ---    -- @since 4.7.0.0-    finiteBitSize :: b -> Int--    -- | Count number of zero bits preceding the most significant set bit.-    ---    -- @-    -- 'countLeadingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a)-    -- @-    ---    -- 'countLeadingZeros' can be used to compute log base 2 via-    ---    -- @-    -- logBase2 x = 'finiteBitSize' x - 1 - 'countLeadingZeros' x-    -- @-    ---    -- Note: The default implementation for this method is intentionally-    -- naive. However, the instances provided for the primitive-    -- integral types are implemented using CPU specific machine-    -- instructions.-    ---    -- @since 4.8.0.0-    countLeadingZeros :: b -> Int-    countLeadingZeros x = (w-1) - go (w-1)-      where-        go i | i < 0       = i -- no bit set-             | testBit x i = i-             | otherwise   = go (i-1)--        w = finiteBitSize x--    -- | Count number of zero bits following the least significant set bit.-    ---    -- @-    -- 'countTrailingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a)-    -- 'countTrailingZeros' . 'negate' = 'countTrailingZeros'-    -- @-    ---    -- The related-    -- <http://en.wikipedia.org/wiki/Find_first_set find-first-set operation>-    -- can be expressed in terms of 'countTrailingZeros' as follows-    ---    -- @-    -- findFirstSet x = 1 + 'countTrailingZeros' x-    -- @-    ---    -- Note: The default implementation for this method is intentionally-    -- naive. However, the instances provided for the primitive-    -- integral types are implemented using CPU specific machine-    -- instructions.-    ---    -- @since 4.8.0.0-    countTrailingZeros :: b -> Int-    countTrailingZeros x = go 0-      where-        go i | i >= w      = i-             | testBit x i = i-             | otherwise   = go (i+1)--        w = finiteBitSize x----- The defaults below are written with lambdas so that e.g.---     bit = bitDefault--- is fully applied, so inlining will happen---- | Default implementation for 'bit'.------ Note that: @bitDefault i = 1 `shiftL` i@------ @since 4.6.0.0-bitDefault :: (Bits a, Num a) => Int -> a-bitDefault = \i -> 1 `shiftL` i-{-# INLINE bitDefault #-}---- | Default implementation for 'testBit'.------ Note that: @testBitDefault x i = (x .&. bit i) /= 0@------ @since 4.6.0.0-testBitDefault ::  (Bits a, Num a) => a -> Int -> Bool-testBitDefault = \x i -> (x .&. bit i) /= 0-{-# INLINE testBitDefault #-}---- | Default implementation for 'popCount'.------ This implementation is intentionally naive. Instances are expected to provide--- an optimized implementation for their size.------ @since 4.6.0.0-popCountDefault :: (Bits a, Num a) => a -> Int-popCountDefault = go 0- where-   go !c 0 = c-   go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant-{-# INLINABLE popCountDefault #-}---- | Interpret 'Bool' as 1-bit bit-field------  @since 4.7.0.0-instance Bits Bool where-    (.&.) = (&&)--    (.|.) = (||)--    xor = (/=)--    complement = not--    shift x 0 = x-    shift _ _ = False--    rotate x _ = x--    bit 0 = True-    bit _ = False--    testBit x 0 = x-    testBit _ _ = False--    bitSizeMaybe _ = Just 1--    bitSize _ = 1--    isSigned _ = False--    popCount False = 0-    popCount True  = 1---- | @since 4.7.0.0-instance FiniteBits Bool where-    finiteBitSize _ = 1-    countTrailingZeros x = if x then 0 else 1-    countLeadingZeros  x = if x then 0 else 1---- | @since 2.01-instance Bits Int where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    -- We want popCnt# to be inlined in user code so that `ghc -msse4.2`-    -- can compile it down to a popcnt instruction without an extra function call-    {-# INLINE popCount #-}--    zeroBits = 0--    bit     = bitDefault--    testBit = testBitDefault--    (I# x#) .&.   (I# y#)          = I# (x# `andI#` y#)-    (I# x#) .|.   (I# y#)          = I# (x# `orI#`  y#)-    (I# x#) `xor` (I# y#)          = I# (x# `xorI#` y#)-    complement (I# x#)             = I# (notI# x#)-    (I# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)      = I# (x# `iShiftL#` i#)-        | otherwise                = I# (x# `iShiftRA#` negateInt# i#)-    (I# x#) `shiftL` (I# i#)-        | isTrue# (i# >=# 0#)      = I# (x# `iShiftL#` i#)-        | otherwise                = overflowError-    (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#)-    (I# x#) `shiftR` (I# i#)-        | isTrue# (i# >=# 0#)      = I# (x# `iShiftRA#` i#)-        | otherwise                = overflowError-    (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#)--    {-# INLINE rotate #-}       -- See Note [Constant folding for rotate]-    (I# x#) `rotate` (I# i#) =-        I# ((x# `uncheckedIShiftL#` i'#) `orI#` (x# `uncheckedIShiftRL#` (wsib -# i'#)))-      where-        !i'# = i# `andI#` (wsib -# 1#)-        !wsib = WORD_SIZE_IN_BITS#   {- work around preprocessor problem (??) -}-    bitSizeMaybe i         = Just (finiteBitSize i)-    bitSize i              = finiteBitSize i--    popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#)))--    isSigned _             = True---- | @since 4.6.0.0-instance FiniteBits Int where-    finiteBitSize _ = WORD_SIZE_IN_BITS-    countLeadingZeros  (I# x#) = I# (word2Int# (clz# (int2Word# x#)))-    {-# INLINE countLeadingZeros #-}-    countTrailingZeros (I# x#) = I# (word2Int# (ctz# (int2Word# x#)))-    {-# INLINE countTrailingZeros #-}---- | @since 2.01-instance Bits Word where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (W# x#) .&.   (W# y#)    = W# (x# `and#` y#)-    (W# x#) .|.   (W# y#)    = W# (x# `or#`  y#)-    (W# x#) `xor` (W# y#)    = W# (x# `xor#` y#)-    complement (W# x#)       = W# (not# x#)-    (W# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)      = W# (x# `shiftL#` i#)-        | otherwise                = W# (x# `shiftRL#` negateInt# i#)-    (W# x#) `shiftL` (I# i#)-        | isTrue# (i# >=# 0#)      = W# (x# `shiftL#` i#)-        | otherwise                = overflowError-    (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#)-    (W# x#) `shiftR` (I# i#)-        | isTrue# (i# >=# 0#)      = W# (x# `shiftRL#` i#)-        | otherwise                = overflowError-    (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#)-    (W# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#) = W# x#-        | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))-        where-        !i'# = i# `andI#` (wsib -# 1#)-        !wsib = WORD_SIZE_IN_BITS#  {- work around preprocessor problem (??) -}-    bitSizeMaybe i           = Just (finiteBitSize i)-    bitSize i                = finiteBitSize i-    isSigned _               = False-    popCount (W# x#)         = I# (word2Int# (popCnt# x#))-    bit                      = bitDefault-    testBit                  = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Word where-    finiteBitSize _ = WORD_SIZE_IN_BITS-    countLeadingZeros  (W# x#) = I# (word2Int# (clz# x#))-    {-# INLINE countLeadingZeros #-}-    countTrailingZeros (W# x#) = I# (word2Int# (ctz# x#))-    {-# INLINE countTrailingZeros #-}---- | @since 2.01-instance Bits Integer where-   (.&.)      = integerAnd-   (.|.)      = integerOr-   xor        = integerXor-   complement = integerComplement-   unsafeShiftR x i = integerShiftR x (fromIntegral i)-   unsafeShiftL x i = integerShiftL x (fromIntegral i)-   shiftR x i@(I# i#)-      | isTrue# (i# >=# 0#) = unsafeShiftR x i-      | otherwise           = overflowError-   shiftL x i@(I# i#)-      | isTrue# (i# >=# 0#) = unsafeShiftL x i-      | otherwise           = overflowError-   shift x i | i >= 0    = integerShiftL x (fromIntegral i)-             | otherwise = integerShiftR x (fromIntegral (negate i))-   testBit x i = integerTestBit x (fromIntegral i)-   zeroBits    = integerZero--   bit (I# i)  = integerBit# (int2Word# i)-   popCount x  = I# (integerPopCount# x)--   rotate x i = shift x i   -- since an Integer never wraps around--   bitSizeMaybe _ = Nothing-   bitSize _  = errorWithoutStackTrace "Data.Bits.bitSize(Integer)"-   isSigned _ = True---- | @since 4.8.0-instance Bits Natural where-   (.&.)         = naturalAnd-   (.|.)         = naturalOr-   xor           = naturalXor-   complement _  = errorWithoutStackTrace-                    "Bits.complement: Natural complement undefined"-   unsafeShiftR x i = naturalShiftR x (fromIntegral i)-   unsafeShiftL x i = naturalShiftL x (fromIntegral i)-   shiftR x i@(I# i#)-      | isTrue# (i# >=# 0#) = unsafeShiftR x i-      | otherwise           = overflowError-   shiftL x i@(I# i#)-      | isTrue# (i# >=# 0#) = unsafeShiftL x i-      | otherwise           = overflowError-   shift x i-     | i >= 0    = naturalShiftL x (fromIntegral i)-     | otherwise = naturalShiftR x (fromIntegral (negate i))-   testBit x i   = naturalTestBit x (fromIntegral i)-   zeroBits      = naturalZero-   clearBit x i  = x `xor` (bit i .&. x)--   bit (I# i)  = naturalBit# (int2Word# i)-   popCount x  = I# (word2Int# (naturalPopCount# x))--   rotate x i = shift x i   -- since an Natural never wraps around--   bitSizeMaybe _ = Nothing-   bitSize _  = errorWithoutStackTrace "Data.Bits.bitSize(Natural)"-   isSigned _ = False----------------------------------------------------------------------------------- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using--- the size of the types as measured by 'Bits' methods.------ A simpler version of this function is:------ > toIntegral :: (Integral a, Integral b) => a -> Maybe b--- > toIntegral x--- >   | toInteger x == y = Just (fromInteger y)--- >   | otherwise        = Nothing--- >   where--- >     y = toInteger x------ This version requires going through 'Integer', which can be inefficient.--- However, @toIntegralSized@ is optimized to allow GHC to statically determine--- the relative type sizes (as measured by 'bitSizeMaybe' and 'isSigned') and--- avoid going through 'Integer' for many types. (The implementation uses--- 'fromIntegral', which is itself optimized with rules for @base@ types but may--- go through 'Integer' for some type pairs.)------ @since 4.8.0.0--toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b-toIntegralSized x                 -- See Note [toIntegralSized optimization]-  | maybe True (<= x) yMinBound-  , maybe True (x <=) yMaxBound = Just y-  | otherwise                   = Nothing-  where-    y = fromIntegral x--    xWidth = bitSizeMaybe x-    yWidth = bitSizeMaybe y--    yMinBound-      | isBitSubType x y = Nothing-      | isSigned x, not (isSigned y) = Just 0-      | isSigned x, isSigned y-      , Just yW <- yWidth = Just (negate $ bit (yW-1)) -- Assumes sub-type-      | otherwise = Nothing--    yMaxBound-      | isBitSubType x y = Nothing-      | isSigned x, not (isSigned y)-      , Just xW <- xWidth, Just yW <- yWidth-      , xW <= yW+1 = Nothing -- Max bound beyond a's domain-      | Just yW <- yWidth = if isSigned y-                            then Just (bit (yW-1)-1)-                            else Just (bit yW-1)-      | otherwise = Nothing-{-# INLINABLE toIntegralSized #-}---- | 'True' if the size of @a@ is @<=@ the size of @b@, where size is measured--- by 'bitSizeMaybe' and 'isSigned'.-isBitSubType :: (Bits a, Bits b) => a -> b -> Bool-isBitSubType x y-  -- Reflexive-  | xWidth == yWidth, xSigned == ySigned = True--  -- Every integer is a subset of 'Integer'-  | ySigned, Nothing == yWidth                  = True-  | not xSigned, not ySigned, Nothing == yWidth = True--  -- Sub-type relations between fixed-with types-  | xSigned == ySigned,   Just xW <- xWidth, Just yW <- yWidth = xW <= yW-  | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <  yW--  | otherwise = False-  where-    xWidth  = bitSizeMaybe x-    xSigned = isSigned     x--    yWidth  = bitSizeMaybe y-    ySigned = isSigned     y-{-# INLINE isBitSubType #-}--{-      Note [Constant folding for rotate]-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The INLINE on the Int instance of rotate enables it to be constant-folded.  For example:-     sumU . mapU (`rotate` 3) . replicateU 10000000 $ (7 :: Int)-goes to:-   Main.$wfold =-     \ (ww_sO7 :: Int#) (ww1_sOb :: Int#) ->-       case ww1_sOb of wild_XM {-         __DEFAULT -> Main.$wfold (+# ww_sO7 56) (+# wild_XM 1);-         10000000 -> ww_sO7-whereas before it was left as a call to $wrotate.--All other Bits instances seem to inline well enough on their-own to enable constant folding; for example 'shift':-     sumU . mapU (`shift` 3) . replicateU 10000000 $ (7 :: Int)- goes to:-     Main.$wfold =-       \ (ww_sOb :: Int#) (ww1_sOf :: Int#) ->-         case ww1_sOf of wild_XM {-           __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1);-           10000000 -> ww_sOb-         }--}---- Note [toIntegralSized optimization]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The code in 'toIntegralSized' relies on GHC optimizing away statically--- decidable branches.------ If both integral types are statically known, GHC will be able optimize the--- code significantly (for @-O1@ and better).------ For instance (as of GHC 7.8.1) the following definitions:------ > w16_to_i32 = toIntegralSized :: Word16 -> Maybe Int32--- >--- > i16_to_w16 = toIntegralSized :: Int16 -> Maybe Word16------ are translated into the following (simplified) /GHC Core/ language:------ > w16_to_i32 = \x -> Just (case x of _ { W16# x# -> I32# (word2Int# x#) })--- >--- > i16_to_w16 = \x -> case eta of _--- >   { I16# b1 -> case tagToEnum# (<=# 0 b1) of _--- >       { False -> Nothing--- >       ; True -> Just (W16# (narrow16Word# (int2Word# b1)))--- >       }--- >   }
− GHC/ByteOrder.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.ByteOrder--- Copyright   :  (c) The University of Glasgow, 1994-2000--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Target byte ordering.------ @since 4.11.0.0--------------------------------------------------------------------------------module GHC.ByteOrder where---- Required for WORDS_BIGENDIAN-#include <ghcautoconf.h>--import GHC.Generics (Generic)---- | Byte ordering.-data ByteOrder-    = BigEndian    -- ^ most-significant-byte occurs in lowest address.-    | LittleEndian -- ^ least-significant-byte occurs in lowest address.-    deriving ( Eq      -- ^ @since 4.11.0.0-             , Ord     -- ^ @since 4.11.0.0-             , Bounded -- ^ @since 4.11.0.0-             , Enum    -- ^ @since 4.11.0.0-             , Read    -- ^ @since 4.11.0.0-             , Show    -- ^ @since 4.11.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | The byte ordering of the target machine.-targetByteOrder :: ByteOrder-#if defined(WORDS_BIGENDIAN)-targetByteOrder = BigEndian-#else-targetByteOrder = LittleEndian-#endif
− GHC/Char.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash #-}--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---- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.-chr :: Int -> Char-chr i@(I# i#)- | isTrue# (int2Word# i# `leWord#` 0x10FFFF##) = C# (chr# i#)- | otherwise-    = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")-
− GHC/Clock.hsc 
@@ -1,25 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Clock-    ( getMonotonicTime-    , getMonotonicTimeNSec-    ) where--import GHC.Base-import GHC.Real-import Data.Word---- | Return monotonic time in seconds, since some unspecified starting point------ @since 4.11.0.0-getMonotonicTime :: IO Double-getMonotonicTime = do w <- getMonotonicTimeNSec-                      return (fromIntegral w / 1000000000)---- | Return monotonic time in nanoseconds, since some unspecified starting point------ @since 4.11.0.0-foreign import ccall unsafe "getMonotonicNSec"-    getMonotonicTimeNSec :: IO Word64-
− GHC/Conc.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}-{-# OPTIONS_GHC -Wno-missing-signatures #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc--- 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)------ Basic concurrency stuff.------------------------------------------------------------------------------------- No: #hide, because bits of this module are exposed by the stm package.--- However, we don't want this module to be the home location for the--- bits it exports, we'd rather have Control.Concurrent and the other--- higher level modules be the home.  Hence: #not-home--module GHC.Conc-        ( ThreadId(..)--        -- * Forking and suchlike-        , forkIO-        , forkIOWithUnmask-        , forkOn-        , forkOnWithUnmask-        , numCapabilities-        , getNumCapabilities-        , setNumCapabilities-        , getNumProcessors-        , numSparks-        , childHandler-        , myThreadId-        , killThread-        , throwTo-        , par-        , pseq-        , runSparks-        , yield-        , labelThread-        , mkWeakThreadId--        , ThreadStatus(..), BlockReason(..)-        , threadStatus-        , threadCapability--        , newStablePtrPrimMVar, PrimMVar--        -- * Waiting-        , threadDelay-        , registerDelay-        , threadWaitRead-        , threadWaitWrite-        , threadWaitReadSTM-        , threadWaitWriteSTM-        , closeFdWith--        -- * Allocation counter and limit-        , setAllocationCounter-        , getAllocationCounter-        , enableAllocationLimit-        , disableAllocationLimit--        -- * TVars-        , STM(..)-        , atomically-        , retry-        , orElse-        , throwSTM-        , catchSTM-        , TVar(..)-        , newTVar-        , newTVarIO-        , readTVar-        , readTVarIO-        , writeTVar-        , unsafeIOToSTM--        -- * Miscellaneous-        , withMVar-#if defined(mingw32_HOST_OS)-        , asyncRead-        , asyncWrite-        , asyncDoProc--        , asyncReadBA-        , asyncWriteBA-#endif--#if !defined(mingw32_HOST_OS)-        , Signal, HandlerFun, setHandler, runHandlers-#endif--        , ensureIOManagerIsRunning-        , ioManagerCapabilitiesChanged--#if defined(mingw32_HOST_OS)-        , ConsoleEvent(..)-        , win32ConsoleHandler-        , toWin32ConsoleEvent-#endif-        , setUncaughtExceptionHandler-        , getUncaughtExceptionHandler--        , reportError, reportStackOverflow, reportHeapOverflow-        ) where--import GHC.Conc.IO-import GHC.Conc.Sync--#if !defined(mingw32_HOST_OS)-import GHC.Conc.Signal-#endif
− GHC/Conc/IO.hs 
@@ -1,219 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , MagicHash-           , UnboxedTuples-  #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.IO--- 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)------ Basic concurrency stuff.------------------------------------------------------------------------------------- No: #hide, because bits of this module are exposed by the stm package.--- However, we don't want this module to be the home location for the--- bits it exports, we'd rather have Control.Concurrent and the other--- higher level modules be the home.  Hence: #not-home--module GHC.Conc.IO-        ( ensureIOManagerIsRunning-        , ioManagerCapabilitiesChanged-        , interruptIOManager--        -- * Waiting-        , threadDelay-        , registerDelay-        , threadWaitRead-        , threadWaitWrite-        , threadWaitReadSTM-        , threadWaitWriteSTM-        , closeFdWith--#if defined(mingw32_HOST_OS)-        , asyncRead-        , asyncWrite-        , asyncDoProc--        , asyncReadBA-        , asyncWriteBA--        , ConsoleEvent(..)-        , win32ConsoleHandler-        , toWin32ConsoleEvent-#endif-        ) where--import Foreign-import GHC.Base-import GHC.Conc.Sync as Sync-import GHC.Real ( fromIntegral )-import System.Posix.Types--#if defined(mingw32_HOST_OS)-import qualified GHC.Conc.Windows as Windows-import GHC.IO.SubSystem-import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA,-                         asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler,-                         toWin32ConsoleEvent)-#else-import qualified GHC.Event.Thread as Event-#endif--ensureIOManagerIsRunning :: IO ()-#if !defined(mingw32_HOST_OS)-ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning-#else-ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning-#endif---- | Interrupts the current wait of the I/O manager if it is currently blocked.--- This instructs it to re-read how much it should wait and to process any--- pending events.------ @since 4.15-interruptIOManager :: IO ()-#if !defined(mingw32_HOST_OS)-interruptIOManager = return ()-#else-interruptIOManager = Windows.interruptIOManager-#endif--ioManagerCapabilitiesChanged :: IO ()-#if !defined(mingw32_HOST_OS)-ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged-#else-ioManagerCapabilitiesChanged = return ()-#endif---- | Block the current thread until data is available to read on the--- given file descriptor (GHC only).------ This will throw an 'Prelude.IOError' if the file descriptor was closed--- while this thread was blocked.  To safely close a file descriptor--- that has been used with 'threadWaitRead', use 'closeFdWith'.-threadWaitRead :: Fd -> IO ()-threadWaitRead fd-#if !defined(mingw32_HOST_OS)-  | threaded  = Event.threadWaitRead fd-#endif-  | otherwise = IO $ \s ->-        case fromIntegral fd of { I# fd# ->-        case waitRead# fd# s of { s' -> (# s', () #)-        }}---- | Block the current thread until data can be written to the--- given file descriptor (GHC only).------ This will throw an 'Prelude.IOError' if the file descriptor was closed--- while this thread was blocked.  To safely close a file descriptor--- that has been used with 'threadWaitWrite', use 'closeFdWith'.-threadWaitWrite :: Fd -> IO ()-threadWaitWrite fd-#if !defined(mingw32_HOST_OS)-  | threaded  = Event.threadWaitWrite fd-#endif-  | otherwise = IO $ \s ->-        case fromIntegral fd of { I# fd# ->-        case waitWrite# fd# s of { s' -> (# s', () #)-        }}---- | Returns an STM action that can be used to wait for data--- to read from a file descriptor. The second returned value--- is an IO action that can be used to deregister interest--- in the file descriptor.-threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())-threadWaitReadSTM fd-#if !defined(mingw32_HOST_OS)-  | threaded  = Event.threadWaitReadSTM fd-#endif-  | otherwise = do-      m <- Sync.newTVarIO False-      t <- Sync.forkIO $ do-        threadWaitRead fd-        Sync.atomically $ Sync.writeTVar m True-      let waitAction = do b <- Sync.readTVar m-                          if b then return () else retry-      let killAction = Sync.killThread t-      return (waitAction, killAction)---- | Returns an STM action that can be used to wait until data--- can be written to a file descriptor. The second returned value--- is an IO action that can be used to deregister interest--- in the file descriptor.-threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())-threadWaitWriteSTM fd-#if !defined(mingw32_HOST_OS)-  | threaded  = Event.threadWaitWriteSTM fd-#endif-  | otherwise = do-      m <- Sync.newTVarIO False-      t <- Sync.forkIO $ do-        threadWaitWrite fd-        Sync.atomically $ Sync.writeTVar m True-      let waitAction = do b <- Sync.readTVar m-                          if b then return () else retry-      let killAction = Sync.killThread t-      return (waitAction, killAction)---- | Close a file descriptor in a concurrency-safe way (GHC only).  If--- you are using 'threadWaitRead' or 'threadWaitWrite' to perform--- blocking I\/O, you /must/ use this function to close file--- descriptors, or blocked threads may not be woken.------ Any threads that are blocked on the file descriptor via--- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having--- IO exceptions thrown.-closeFdWith :: (Fd -> IO ()) -- ^ Low-level action that performs the real close.-            -> Fd            -- ^ File descriptor to close.-            -> IO ()-closeFdWith close fd-#if !defined(mingw32_HOST_OS)-  | threaded  = Event.closeFdWith close fd-#endif-  | otherwise = close fd---- | Suspends the current thread for a given number of microseconds--- (GHC only).------ There is no guarantee that the thread will be rescheduled promptly--- when the delay has expired, but the thread will never continue to--- run /earlier/ than specified.----threadDelay :: Int -> IO ()-threadDelay time-#if defined(mingw32_HOST_OS)-  | isWindowsNativeIO = Windows.threadDelay time-  | threaded          = Windows.threadDelay time-#else-  | threaded          = Event.threadDelay time-#endif-  | otherwise         = IO $ \s ->-        case time of { I# time# ->-        case delay# time# s of { s' -> (# s', () #)-        }}---- | Switch the value of returned 'TVar' from initial value 'False' to 'True'--- after a given number of microseconds. The caveats associated with--- 'threadDelay' also apply.----registerDelay :: Int -> IO (TVar Bool)-registerDelay usecs-#if defined(mingw32_HOST_OS)-  | isWindowsNativeIO = Windows.registerDelay usecs-  | threaded          = Windows.registerDelay usecs-#else-  | threaded          = Event.registerDelay usecs-#endif-  | otherwise         = errorWithoutStackTrace "registerDelay: requires -threaded"--foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
− GHC/Conc/POSIX.hs 
@@ -1,304 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_GHC -Wno-missing-signatures #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.POSIX--- 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)------ Windows I/O manager------ This is the I/O manager based on posix FDs for windows.--- When using the winio manager these functions may not--- be used as they will behave in unexpected ways.------ TODO: This manager is currently the default. But we will eventually--- switch to use winio instead.------------------------------------------------------------------------------------- #not-home-module GHC.Conc.POSIX-       ( ensureIOManagerIsRunning-       , interruptIOManager--       -- * Waiting-       , threadDelay-       , registerDelay--       -- * Miscellaneous-       , asyncRead-       , asyncWrite-       , asyncDoProc--       , asyncReadBA-       , asyncWriteBA--       , module GHC.Event.Windows.ConsoleEvent-       ) where---#include "windows_cconv.h"--import Data.Bits (shiftR)-import GHC.Base-import GHC.Conc.Sync-import GHC.Conc.POSIX.Const-import GHC.Event.Windows.ConsoleEvent-import GHC.IO (unsafePerformIO)-import GHC.IORef-import GHC.MVar-import GHC.Num (Num(..))-import GHC.Ptr-import GHC.Real (div, fromIntegral)-import GHC.Word (Word32, Word64)-import GHC.Windows---- ------------------------------------------------------------------------------- Thread waiting---- Note: threadWaitRead and threadWaitWrite aren't really functional--- on Win32, but left in there because lib code (still) uses them (the manner--- in which they're used doesn't cause problems on a Win32 platform though.)--asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)-asyncRead  (I# fd) (I# isSock) (I# len) (Ptr buf) =-  IO $ \s -> case asyncRead# fd isSock len buf s of-               (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)--asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)-asyncWrite  (I# fd) (I# isSock) (I# len) (Ptr buf) =-  IO $ \s -> case asyncWrite# fd isSock len buf s of-               (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)--asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int-asyncDoProc (FunPtr proc) (Ptr param) =-    -- the 'length' value is ignored; simplifies implementation of-    -- the async*# primops to have them all return the same result.-  IO $ \s -> case asyncDoProc# proc param s  of-               (# s', _len#, err# #) -> (# s', I# err# #)---- to aid the use of these primops by the IO Handle implementation,--- provide the following convenience funs:---- this better be a pinned byte array!-asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)-asyncReadBA fd isSock len off bufB =-  asyncRead fd isSock len ((Ptr (mutableByteArrayContents# bufB)) `plusPtr` off)--asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)-asyncWriteBA fd isSock len off bufB =-  asyncWrite fd isSock len ((Ptr (mutableByteArrayContents# bufB)) `plusPtr` off)---- ------------------------------------------------------------------------------- Threaded RTS implementation of threadDelay---- | Suspends the current thread for a given number of microseconds--- (GHC only).------ There is no guarantee that the thread will be rescheduled promptly--- when the delay has expired, but the thread will never continue to--- run /earlier/ than specified.----threadDelay :: Int -> IO ()-threadDelay time-  | threaded  = waitForDelayEvent time-  | otherwise = IO $ \s ->-        case time of { I# time# ->-        case delay# time# s of { s' -> (# s', () #)-        }}---- | Set the value of returned TVar to True after a given number of--- microseconds. The caveats associated with threadDelay also apply.----registerDelay :: Int -> IO (TVar Bool)-registerDelay usecs-  | threaded = waitForDelayEventSTM usecs-  | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded"--foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool--waitForDelayEvent :: Int -> IO ()-waitForDelayEvent usecs = do-  m <- newEmptyMVar-  target <- calculateTarget usecs-  _ <- atomicModifyIORef'_ pendingDelays (\xs -> Delay target m : xs)-  prodServiceThread-  takeMVar m---- Delays for use in STM-waitForDelayEventSTM :: Int -> IO (TVar Bool)-waitForDelayEventSTM usecs = do-   t <- atomically $ newTVar False-   target <- calculateTarget usecs-   _ <- atomicModifyIORef'_ pendingDelays (\xs -> DelaySTM target t : xs)-   prodServiceThread-   return t--calculateTarget :: Int -> IO USecs-calculateTarget usecs = do-    now <- getMonotonicUSec-    return $ now + (fromIntegral usecs)--data DelayReq-  = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())-  | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)--{-# NOINLINE pendingDelays #-}-pendingDelays :: IORef [DelayReq]-pendingDelays = unsafePerformIO $ do-   m <- newIORef []-   sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore--foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"-    getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)--{-# NOINLINE ioManagerThread #-}-ioManagerThread :: MVar (Maybe ThreadId)-ioManagerThread = unsafePerformIO $ do-   m <- newMVar Nothing-   sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore--foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"-    getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)--ensureIOManagerIsRunning :: IO ()-ensureIOManagerIsRunning-  | threaded  = startIOManagerThread-  | otherwise = return ()--interruptIOManager :: IO ()-interruptIOManager = return ()--startIOManagerThread :: IO ()-startIOManagerThread =-  modifyMVar_ ioManagerThread $ \old -> do-    let create = do t <- forkIO ioManager;-                    labelThread t "IOManagerThread";-                    return (Just t)-    case old of-      Nothing -> create-      Just t  -> do-        s <- threadStatus t-        case s of-          ThreadFinished -> create-          ThreadDied     -> create-          _other         -> return (Just t)--insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]-insertDelay d [] = [d]-insertDelay d1 ds@(d2 : rest)-  | delayTime d1 <= delayTime d2 = d1 : ds-  | otherwise                    = d2 : insertDelay d1 rest--delayTime :: DelayReq -> USecs-delayTime (Delay t _) = t-delayTime (DelaySTM t _) = t--type USecs = Word64-type NSecs = Word64--foreign import ccall unsafe "getMonotonicNSec"-  getMonotonicNSec :: IO NSecs--getMonotonicUSec :: IO USecs-getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec--{-# NOINLINE prodding #-}-prodding :: IORef Bool-prodding = unsafePerformIO $ do-   r <- newIORef False-   sharedCAF r getOrSetGHCConcWindowsProddingStore--foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"-    getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)--prodServiceThread :: IO ()-prodServiceThread = do-  -- NB. use atomicSwapIORef here, otherwise there are race-  -- conditions in which prodding is left at True but the server is-  -- blocked in select().-  was_set <- atomicSwapIORef prodding True-  when (not was_set) wakeupIOManager---- ------------------------------------------------------------------------------- Windows IO manager thread--ioManager :: IO ()-ioManager = do-  wakeup <- c_getIOManagerEvent-  service_loop wakeup []--service_loop :: HANDLE          -- read end of pipe-             -> [DelayReq]      -- current delay requests-             -> IO ()--service_loop wakeup old_delays = do-  -- pick up new delay requests-  new_delays <- atomicSwapIORef pendingDelays []-  let  delays = foldr insertDelay old_delays new_delays--  now <- getMonotonicUSec-  (delays', timeout) <- getDelay now delays--  r <- c_WaitForSingleObject wakeup timeout-  case r of-    0xffffffff -> throwGetLastError "service_loop"-    0 -> do-        r2 <- c_readIOManagerEvent-        exit <--              case r2 of-                _ | r2 == io_MANAGER_WAKEUP -> return False-                _ | r2 == io_MANAGER_DIE    -> return True-                0 -> return False -- spurious wakeup-                _ -> do start_console_handler (r2 `shiftR` 1); return False-        when (not exit) $ service_cont wakeup delays'--    _other -> service_cont wakeup delays' -- probably timeout--service_cont :: HANDLE -> [DelayReq] -> IO ()-service_cont wakeup delays = do-  _ <- atomicSwapIORef prodding False-  service_loop wakeup delays--wakeupIOManager :: IO ()-wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP---- Walk the queue of pending delays, waking up any that have passed--- and return the smallest delay to wait for.  The queue of pending--- delays is kept ordered.-getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)-getDelay _   [] = return ([], iNFINITE)-getDelay now all@(d : rest)-  = case d of-     Delay time m | now >= time -> do-        putMVar m ()-        getDelay now rest-     DelaySTM time t | now >= time -> do-        atomically $ writeTVar t True-        getDelay now rest-     _otherwise ->-        -- delay is in millisecs for WaitForSingleObject-        let micro_seconds = delayTime d - now-            milli_seconds = (micro_seconds + 999) `div` 1000-        in return (all, fromIntegral milli_seconds)--foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)-  c_getIOManagerEvent :: IO HANDLE--foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)-  c_readIOManagerEvent :: IO Word32--foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)-  c_sendIOManagerEvent :: Word32 -> IO ()--foreign import WINDOWS_CCONV "WaitForSingleObject"-   c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD-
− GHC/Conc/POSIX/Const.hsc 
@@ -1,29 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.POSIX.Const--- Copyright   :  (c) The University of Glasgow, 2019--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Constants shared with the rts, GHC.Conc.POSIX uses MagicHash which confuses--- hsc2hs so these are moved to a new module.------------------------------------------------------------------------------------- #not-home-module GHC.Conc.POSIX.Const where--import Data.Word--#include <Rts.h>--io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32-io_MANAGER_WAKEUP = #{const IO_MANAGER_WAKEUP}-io_MANAGER_DIE    = #{const IO_MANAGER_DIE}
− GHC/Conc/Signal.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Conc.Signal-        ( Signal-        , HandlerFun-        , setHandler-        , runHandlers-        , runHandlersPtr-        ) where--import Control.Concurrent.MVar (MVar, newMVar, withMVar)-import Data.Dynamic (Dynamic)-import Foreign.C.Types (CInt)-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr)-import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr,-                          deRefStablePtr, freeStablePtr, newStablePtr)-import Foreign.Ptr (Ptr, castPtr)-import Foreign.Marshal.Alloc (finalizerFree)-import GHC.Arr (inRange)-import GHC.Base-import GHC.Conc.Sync (forkIO)-import GHC.IO (mask_, unsafePerformIO)-import GHC.IOArray (IOArray, boundsIOArray, newIOArray,-                    unsafeReadIOArray, unsafeWriteIOArray)-import GHC.Real (fromIntegral)-import GHC.Word (Word8)----------------------------------------------------------------------------- Signal handling--type Signal = CInt--maxSig :: Int-maxSig = 64--type HandlerFun = ForeignPtr Word8 -> IO ()---- Lock used to protect concurrent access to signal_handlers.  Symptom--- of this race condition is GHC bug #1922, although that bug was on--- Windows a similar bug also exists on Unix.-signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))-signal_handlers = unsafePerformIO $ do-  arr <- newIOArray (0, maxSig) Nothing-  m <- newMVar arr-  sharedCAF m getOrSetGHCConcSignalSignalHandlerStore-{-# NOINLINE signal_handlers #-}--foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore"-  getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a)--setHandler :: Signal -> Maybe (HandlerFun, Dynamic)-           -> IO (Maybe (HandlerFun, Dynamic))-setHandler sig handler = do-  let int = fromIntegral sig-  withMVar signal_handlers $ \arr ->-    if not (inRange (boundsIOArray arr) int)-      then errorWithoutStackTrace "GHC.Conc.setHandler: signal out of range"-      else do old <- unsafeReadIOArray arr int-              unsafeWriteIOArray arr int handler-              return old--runHandlers :: ForeignPtr Word8 -> Signal -> IO ()-runHandlers p_info sig = do-  let int = fromIntegral sig-  withMVar signal_handlers $ \arr ->-    if not (inRange (boundsIOArray arr) int)-      then return ()-      else do handler <- unsafeReadIOArray arr int-              case handler of-                Nothing -> return ()-                Just (f,_)  -> do _ <- forkIO (f p_info)-                                  return ()---- It is our responsibility to free the memory buffer, so we create a--- foreignPtr.-runHandlersPtr :: Ptr Word8 -> Signal -> IO ()-runHandlersPtr p s = do-  fp <- newForeignPtr finalizerFree p-  runHandlers fp s---- Machinery needed to ensure that we only have one copy of certain--- CAFs in this module even when the base package is present twice, as--- it is when base is dynamically loaded into GHCi.  The RTS keeps--- track of the single true value of the CAF, so even when the CAFs in--- the dynamically-loaded base package are reverted, nothing bad--- happens.----sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a-sharedCAF a get_or_set =-  mask_ $ do-    stable_ref <- newStablePtr a-    let ref = castPtr (castStablePtrToPtr stable_ref)-    ref2 <- get_or_set ref-    if ref == ref2-      then return a-      else do freeStablePtr stable_ref-              deRefStablePtr (castPtrToStablePtr (castPtr ref2))-
− GHC/Conc/Sync.hs 
@@ -1,922 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE UnliftedFFITypes #-}-{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.Sync--- 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)------ Basic concurrency stuff.------------------------------------------------------------------------------------- No: #hide, because bits of this module are exposed by the stm package.--- However, we don't want this module to be the home location for the--- bits it exports, we'd rather have Control.Concurrent and the other--- higher level modules be the home.  Hence:---- #not-home-module GHC.Conc.Sync-        ( ThreadId(..)-        , showThreadId--        -- * Forking and suchlike-        , forkIO-        , forkIOWithUnmask-        , forkOn-        , forkOnWithUnmask-        , numCapabilities-        , getNumCapabilities-        , setNumCapabilities-        , getNumProcessors-        , numSparks-        , childHandler-        , myThreadId-        , killThread-        , throwTo-        , par-        , pseq-        , runSparks-        , yield-        , labelThread-        , mkWeakThreadId--        , ThreadStatus(..), BlockReason(..)-        , threadStatus-        , threadCapability--        , newStablePtrPrimMVar, PrimMVar--        -- * Allocation counter and quota-        , setAllocationCounter-        , getAllocationCounter-        , enableAllocationLimit-        , disableAllocationLimit--        -- * TVars-        , STM(..)-        , atomically-        , retry-        , orElse-        , throwSTM-        , catchSTM-        , TVar(..)-        , newTVar-        , newTVarIO-        , readTVar-        , readTVarIO-        , writeTVar-        , unsafeIOToSTM--        -- * Miscellaneous-        , withMVar-        , modifyMVar_--        , setUncaughtExceptionHandler-        , getUncaughtExceptionHandler--        , reportError, reportStackOverflow, reportHeapOverflow--        , sharedCAF-        ) where--import Foreign-import Foreign.C--import Data.Typeable-import Data.Maybe--import GHC.Base-import {-# SOURCE #-} GHC.IO.Handle ( hFlush )-import {-# SOURCE #-} GHC.IO.StdHandles ( stdout )-import GHC.Int-import GHC.IO-import GHC.IO.Encoding.UTF8-import GHC.IO.Exception-import GHC.Exception-import qualified GHC.Foreign-import GHC.IORef-import GHC.MVar-import GHC.Ptr-import GHC.Real         ( fromIntegral )-import GHC.Show         ( Show(..), showParen, showString )-import GHC.Stable       ( StablePtr(..) )-import GHC.Weak--import Unsafe.Coerce    ( unsafeCoerce# )--infixr 0 `par`, `pseq`---------------------------------------------------------------------------------- 'ThreadId', 'par', and 'fork'--------------------------------------------------------------------------------data ThreadId = ThreadId ThreadId#--- ToDo: data ThreadId = ThreadId (Weak ThreadId#)--- But since ThreadId# is unlifted, the Weak type must use open--- type variables.-{- ^-A 'ThreadId' is an abstract type representing a handle to a thread.-'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where-the 'Ord' instance implements an arbitrary total ordering over-'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued-'ThreadId' to string form; showing a 'ThreadId' value is occasionally-useful when debugging or diagnosing the behaviour of a concurrent-program.--/Note/: in GHC, if you have a 'ThreadId', you essentially have-a pointer to the thread itself.  This means the thread itself can\'t be-garbage collected until you drop the 'ThreadId'.-This misfeature will hopefully be corrected at a later date.---}---- | @since 4.2.0.0-instance Show ThreadId where-   showsPrec d t = showParen (d >= 11) $-        showString "ThreadId " .-        showsPrec d (getThreadId (id2TSO t))--showThreadId :: ThreadId -> String-showThreadId = show--foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt--id2TSO :: ThreadId -> ThreadId#-id2TSO (ThreadId t) = t--foreign import ccall unsafe "eq_thread" eq_thread :: ThreadId# -> ThreadId# -> CBool--foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt--- Returns -1, 0, 1---- | @since 4.2.0.0-instance Eq ThreadId where-  ThreadId t1 == ThreadId t2 = eq_thread t1 t2 /= 0---- | @since 4.2.0.0-instance Ord ThreadId where-  compare (ThreadId t1) (ThreadId t2) = case cmp_thread t1 t2 of-    -1 -> LT-    0  -> EQ-    _  -> GT---- | Every thread has an allocation counter that tracks how much--- memory has been allocated by the thread.  The counter is--- initialized to zero, and 'setAllocationCounter' sets the current--- value.  The allocation counter counts *down*, so in the absence of--- a call to 'setAllocationCounter' its value is the negation of the--- number of bytes of memory allocated by the thread.------ There are two things that you can do with this counter:------ * Use it as a simple profiling mechanism, with---   'getAllocationCounter'.------ * Use it as a resource limit.  See 'enableAllocationLimit'.------ Allocation accounting is accurate only to about 4Kbytes.------ @since 4.8.0.0-setAllocationCounter :: Int64 -> IO ()-setAllocationCounter (I64# i) = IO $ \s ->-  case setThreadAllocationCounter# i s of s' -> (# s', () #)---- | Return the current value of the allocation counter for the--- current thread.------ @since 4.8.0.0-getAllocationCounter :: IO Int64-getAllocationCounter = IO $ \s ->-  case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #)---- | Enables the allocation counter to be treated as a limit for the--- current thread.  When the allocation limit is enabled, if the--- allocation counter counts down below zero, the thread will be sent--- the 'AllocationLimitExceeded' asynchronous exception.  When this--- happens, the counter is reinitialised (by default--- 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.  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--- memory and retain anything between none and all of it.  It is--- better to think of the allocation limit as a limit on--- /CPU time/, rather than a limit on memory.------ Compared to using timeouts, allocation limits don't count time--- spent blocked or in foreign calls.------ @since 4.8.0.0-enableAllocationLimit :: IO ()-enableAllocationLimit = do-  ThreadId t <- myThreadId-  rts_enableThreadAllocationLimit t---- | Disable allocation limit processing for the current thread.------ @since 4.8.0.0-disableAllocationLimit :: IO ()-disableAllocationLimit = do-  ThreadId t <- myThreadId-  rts_disableThreadAllocationLimit t--foreign import ccall unsafe "rts_enableThreadAllocationLimit"-  rts_enableThreadAllocationLimit :: ThreadId# -> IO ()--foreign import ccall unsafe "rts_disableThreadAllocationLimit"-  rts_disableThreadAllocationLimit :: ThreadId# -> IO ()--{- |-Creates a new thread to run the 'IO' computation passed as the-first argument, and returns the 'ThreadId' of the newly created-thread.--The new thread will be a lightweight, /unbound/ thread.  Foreign calls-made by this thread are not guaranteed to be made by any particular OS-thread; if you need foreign calls to be made by a particular OS-thread, then use 'Control.Concurrent.forkOS' instead.--The new thread inherits the /masked/ state of the parent (see-'Control.Exception.mask').--The newly created thread has an exception handler that discards the-exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and-'ThreadKilled', and passes all other exceptions to the uncaught-exception handler.--}-forkIO :: IO () -> IO ThreadId-forkIO action = IO $ \ s ->-   case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)- where-  -- We must use 'catch' rather than 'catchException' because the action-  -- could be bottom. #13330-  action_plus = catch action childHandler---- | Like 'forkIO', but the child thread is passed a function that can--- be used to unmask asynchronous exceptions.  This function is--- typically used in the following way------ >  ... mask_ $ forkIOWithUnmask $ \unmask ->--- >                 catch (unmask ...) handler------ so that the exception handler in the child thread is established--- with asynchronous exceptions masked, meanwhile the main body of--- the child thread is executed in the unmasked state.------ Note that the unmask function passed to the child thread should--- only be used in that thread; the behaviour is undefined if it is--- invoked in a different thread.------ @since 4.4.0.0-forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId-forkIOWithUnmask io = forkIO (io unsafeUnmask)--{- |-Like 'forkIO', but lets you specify on which capability the thread-should run.  Unlike a `forkIO` thread, a thread created by `forkOn`-will stay on the same capability for its entire lifetime (`forkIO`-threads can migrate between capabilities according to the scheduling-policy).  `forkOn` is useful for overriding the scheduling policy when-you know in advance how best to distribute the threads.--The `Int` argument specifies a /capability number/ (see-'getNumCapabilities').  Typically capabilities correspond to physical-processors, but the exact behaviour is implementation-dependent.  The-value passed to 'forkOn' is interpreted modulo the total number of-capabilities as returned by 'getNumCapabilities'.--GHC note: the number of capabilities is specified by the @+RTS -N@-option when the program is started.  Capabilities can be fixed to-actual processor cores with @+RTS -qa@ if the underlying operating-system supports that, although in practice this is usually unnecessary-(and may actually degrade performance in some cases - experimentation-is recommended).--@since 4.4.0.0--}-forkOn :: Int -> IO () -> IO ThreadId-forkOn (I# cpu) action = IO $ \ s ->-   case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)- where-  -- We must use 'catch' rather than 'catchException' because the action-  -- could be bottom. #13330-  action_plus = catch action childHandler---- | Like 'forkIOWithUnmask', but the child thread is pinned to the--- given CPU, as with 'forkOn'.------ @since 4.4.0.0-forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId-forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)---- | the value passed to the @+RTS -N@ flag.  This is the number of--- Haskell threads that can run truly simultaneously at any given--- time, and is typically set to the number of physical processor cores on--- the machine.------ Strictly speaking it is better to use 'getNumCapabilities', because--- the number of capabilities might vary at runtime.----numCapabilities :: Int-numCapabilities = unsafePerformIO $ getNumCapabilities--{- |-Returns the number of Haskell threads that can run truly-simultaneously (on separate physical processors) at any given time.  To change-this value, use 'setNumCapabilities'.--@since 4.4.0.0--}-getNumCapabilities :: IO Int-getNumCapabilities = do-   n <- peek enabled_capabilities-   return (fromIntegral n)--{- |-Set the number of Haskell threads that can run truly simultaneously-(on separate physical processors) at any given time.  The number-passed to `forkOn` is interpreted modulo this value.  The initial-value is given by the @+RTS -N@ runtime flag.--This is also the number of threads that will participate in parallel-garbage collection.  It is strongly recommended that the number of-capabilities is not set larger than the number of physical processor-cores, and it may often be beneficial to leave one or more cores free-to avoid contention with other processes in the machine.--@since 4.5.0.0--}-setNumCapabilities :: Int -> IO ()-setNumCapabilities i-  | i <= 0    = failIO $ "setNumCapabilities: Capability count ("++show i++") must be positive"-  | otherwise = c_setNumCapabilities (fromIntegral i)--foreign import ccall safe "setNumCapabilities"-  c_setNumCapabilities :: CUInt -> IO ()---- | Returns the number of CPUs that the machine has------ @since 4.5.0.0-getNumProcessors :: IO Int-getNumProcessors = fmap fromIntegral c_getNumberOfProcessors--foreign import ccall unsafe "getNumberOfProcessors"-  c_getNumberOfProcessors :: IO CUInt---- | Returns the number of sparks currently in the local spark pool-numSparks :: IO Int-numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)--foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt--childHandler :: SomeException -> IO ()-childHandler err = catch (real_handler err) childHandler-  -- We must use catch here rather than catchException. If the-  -- raised exception throws an (imprecise) exception, then real_handler err-  -- will do so as well. If we use catchException here, then we could miss-  -- that exception.--real_handler :: SomeException -> IO ()-real_handler se-  | Just BlockedIndefinitelyOnMVar <- fromException se  =  return ()-  | Just BlockedIndefinitelyOnSTM  <- fromException se  =  return ()-  | Just ThreadKilled              <- fromException se  =  return ()-  | Just StackOverflow             <- fromException se  =  reportStackOverflow-  | otherwise                                           =  reportError se--{- | 'killThread' raises the 'ThreadKilled' exception in the given-thread (GHC only).--> killThread tid = throwTo tid ThreadKilled---}-killThread :: ThreadId -> IO ()-killThread tid = throwTo tid ThreadKilled--{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).--Exception delivery synchronizes between the source and target thread:-'throwTo' does not return until the exception has been raised in the-target thread. The calling thread can thus be certain that the target-thread has received the exception.  Exception delivery is also atomic-with respect to other exceptions. Atomicity is a useful property to have-when dealing with race conditions: e.g. if there are two threads that-can kill each other, it is guaranteed that only one of the threads-will get to kill the other.--Whatever work the target thread was doing when the exception was-raised is not lost: the computation is suspended until required by-another thread.--If the target thread is currently making a foreign call, then the-exception will not be raised (and hence 'throwTo' will not return)-until the call has completed.  This is the case regardless of whether-the call is inside a 'mask' or not.  However, in GHC a foreign call-can be annotated as @interruptible@, in which case a 'throwTo' will-cause the RTS to attempt to cause the call to return; see the GHC-documentation for more details.--Important note: the behaviour of 'throwTo' differs from that described in-the paper \"Asynchronous exceptions in Haskell\"-(<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).-In the paper, 'throwTo' is non-blocking; but the library implementation adopts-a more synchronous design in which 'throwTo' does not return until the exception-is received by the target thread.  The trade-off is discussed in Section 9 of the paper.-Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of-the paper).  Unlike other interruptible operations, however, 'throwTo'-is /always/ interruptible, even if it does not actually block.--There is no guarantee that the exception will be delivered promptly,-although the runtime will endeavour to ensure that arbitrary-delays don't occur.  In GHC, an exception can only be raised when a-thread reaches a /safe point/, where a safe point is where memory-allocation occurs.  Some loops do not perform any memory allocation-inside the loop and therefore cannot be interrupted by a 'throwTo'.--If the target of 'throwTo' is the calling thread, then the behaviour-is the same as 'Control.Exception.throwIO', except that the exception-is thrown as an asynchronous exception.  This means that if there is-an enclosing pure computation, which would be the case if the current-IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', that-computation is not permanently replaced by the exception, but is-suspended as if it had received an asynchronous exception.--Note that if 'throwTo' is called with the current thread as the-target, the exception will be thrown even if the thread is currently-inside 'mask' or 'uninterruptibleMask'.-  -}-throwTo :: Exception e => ThreadId -> e -> IO ()-throwTo (ThreadId tid) ex = IO $ \ s ->-   case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)---- | Returns the 'ThreadId' of the calling thread (GHC only).-myThreadId :: IO ThreadId-myThreadId = IO $ \s ->-   case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)----- | The 'yield' action allows (forces, in a co-operative multitasking--- implementation) a context-switch to any other currently runnable--- threads (if any), and is occasionally useful when implementing--- concurrency abstractions.-yield :: IO ()-yield = IO $ \s ->-   case (yield# s) of s1 -> (# s1, () #)--{- | 'labelThread' stores a string as identifier for this thread. This-identifier will be used in the debugging output to make distinction of-different threads easier (otherwise you only have the thread state object\'s-address in the heap). It also emits an event to the RTS eventlog.--Other applications like the graphical Concurrent Haskell Debugger-(<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload-'labelThread' for their purposes as well.--}--labelThread :: ThreadId -> String -> IO ()-labelThread (ThreadId t) str =-    GHC.Foreign.withCString utf8 str $ \(Ptr p) ->-    IO $ \ s ->-     case labelThread# t p s of s1 -> (# s1, () #)----      Nota Bene: 'pseq' used to be 'seq'---                 but 'seq' is now defined in GHC.Prim------ "pseq" is defined a bit weirdly (see below)------ The reason for the strange "lazy" call is that--- it fools the compiler into thinking that pseq  and par are non-strict in--- their second argument (even if it inlines pseq at the call site).--- If it thinks pseq is strict in "y", then it often evaluates--- "y" before "x", which is totally wrong.--{-# INLINE pseq  #-}-pseq :: a -> b -> b-pseq  x y = x `seq` lazy y--{-# INLINE par  #-}-par :: a -> b -> b-par  x y = case (par# x) of { _ -> lazy y }---- | Internal function used by the RTS to run sparks.-runSparks :: IO ()-runSparks = IO loop-  where loop s = case getSpark# s of-                   (# s', n, p #) ->-                      if isTrue# (n ==# 0#)-                      then (# s', () #)-                      else p `seq` loop s'--data BlockReason-  = BlockedOnMVar-        -- ^blocked on 'MVar'-  {- possibly (see 'threadstatus' below):-  | BlockedOnMVarRead-        -- ^blocked on reading an empty 'MVar'-  -}-  | BlockedOnBlackHole-        -- ^blocked on a computation in progress by another thread-  | BlockedOnException-        -- ^blocked in 'throwTo'-  | BlockedOnSTM-        -- ^blocked in 'retry' in an STM transaction-  | BlockedOnForeignCall-        -- ^currently in a foreign call-  | BlockedOnOther-        -- ^blocked on some other resource.  Without @-threaded@,-        -- I\/O and 'Control.Concurrent.threadDelay' show up as-        -- 'BlockedOnOther', with @-threaded@ they show up as 'BlockedOnMVar'.-  deriving ( Eq   -- ^ @since 4.3.0.0-           , Ord  -- ^ @since 4.3.0.0-           , Show -- ^ @since 4.3.0.0-           )---- | The current status of a thread-data ThreadStatus-  = ThreadRunning-        -- ^the thread is currently runnable or running-  | ThreadFinished-        -- ^the thread has finished-  | ThreadBlocked  BlockReason-        -- ^the thread is blocked on some resource-  | ThreadDied-        -- ^the thread received an uncaught exception-  deriving ( Eq   -- ^ @since 4.3.0.0-           , Ord  -- ^ @since 4.3.0.0-           , Show -- ^ @since 4.3.0.0-           )--threadStatus :: ThreadId -> IO ThreadStatus-threadStatus (ThreadId t) = IO $ \s ->-   case threadStatus# t s of-    (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)-   where-        -- NB. keep these in sync with includes/rts/Constants.h-     mk_stat 0  = ThreadRunning-     mk_stat 1  = ThreadBlocked BlockedOnMVar-     mk_stat 2  = ThreadBlocked BlockedOnBlackHole-     mk_stat 6  = ThreadBlocked BlockedOnSTM-     mk_stat 10 = ThreadBlocked BlockedOnForeignCall-     mk_stat 11 = ThreadBlocked BlockedOnForeignCall-     mk_stat 12 = ThreadBlocked BlockedOnException-     mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead-     -- NB. these are hardcoded in rts/PrimOps.cmm-     mk_stat 16 = ThreadFinished-     mk_stat 17 = ThreadDied-     mk_stat _  = ThreadBlocked BlockedOnOther---- | Returns the number of the capability on which the thread is currently--- running, and a boolean indicating whether the thread is locked to--- that capability or not.  A thread is locked to a capability if it--- was created with @forkOn@.------ @since 4.4.0.0-threadCapability :: ThreadId -> IO (Int, Bool)-threadCapability (ThreadId t) = IO $ \s ->-   case threadStatus# t s of-     (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #)---- | Make a weak pointer to a 'ThreadId'.  It can be important to do--- this if you want to hold a reference to a 'ThreadId' while still--- allowing the thread to receive the @BlockedIndefinitely@ family of--- exceptions (e.g. 'BlockedIndefinitelyOnMVar').  Holding a normal--- 'ThreadId' reference will prevent the delivery of--- @BlockedIndefinitely@ exceptions because the reference could be--- used as the target of 'throwTo' at any time, which would unblock--- the thread.------ Holding a @Weak ThreadId@, on the other hand, will not prevent the--- thread from receiving @BlockedIndefinitely@ exceptions.  It is--- still possible to throw an exception to a @Weak ThreadId@, but the--- caller must use @deRefWeak@ first to determine whether the thread--- still exists.------ @since 4.6.0.0-mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)-mkWeakThreadId t@(ThreadId t#) = IO $ \s ->-   case mkWeakNoFinalizer# t# t s of-      (# s1, w #) -> (# s1, Weak w #)---data PrimMVar---- | Make a StablePtr that can be passed to the C function--- @hs_try_putmvar()@.  The RTS wants a 'StablePtr' to the underlying--- 'MVar#', but a 'StablePtr#' can only refer to lifted types, so we--- have to cheat by coercing.-newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar)-newStablePtrPrimMVar (MVar m) = IO $ \s0 ->-  case makeStablePtr# (unsafeCoerce# m :: PrimMVar) s0 of-    -- Coerce unlifted  m :: MVar# RealWorld ()-    --     to lifted    PrimMVar-    -- apparently because mkStablePtr is not levity-polymorphic-    (# s1, sp #) -> (# s1, StablePtr sp #)---------------------------------------------------------------------------------- Transactional heap operations---------------------------------------------------------------------------------- TVars are shared memory locations which support atomic memory--- transactions.---- |A monad supporting atomic memory transactions.-newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))--unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))-unSTM (STM a) = a---- | @since 4.3.0.0-instance  Functor STM where-   fmap f x = x >>= (pure . f)---- | @since 4.8.0.0-instance Applicative STM where-  {-# INLINE pure #-}-  {-# INLINE (*>) #-}-  {-# INLINE liftA2 #-}-  pure x = returnSTM x-  (<*>) = ap-  liftA2 = liftM2-  m *> k = thenSTM m k---- | @since 4.3.0.0-instance  Monad STM  where-    {-# INLINE (>>=)  #-}-    m >>= k     = bindSTM m k-    (>>) = (*>)--bindSTM :: STM a -> (a -> STM b) -> STM b-bindSTM (STM m) k = STM ( \s ->-  case m s of-    (# new_s, a #) -> unSTM (k a) new_s-  )--thenSTM :: STM a -> STM b -> STM b-thenSTM (STM m) k = STM ( \s ->-  case m s of-    (# new_s, _ #) -> unSTM k new_s-  )--returnSTM :: a -> STM a-returnSTM x = STM (\s -> (# s, x #))---- | @since 4.8.0.0-instance Alternative STM where-  empty = retry-  (<|>) = orElse---- | @since 4.3.0.0-instance MonadPlus STM---- | Unsafely performs IO in the STM monad.  Beware: this is a highly--- dangerous thing to do.------   * The STM implementation will often run transactions multiple---     times, so you need to be prepared for this if your IO has any---     side effects.------   * The STM implementation will abort transactions that are known to---     be invalid and need to be restarted.  This may happen in the middle---     of `unsafeIOToSTM`, so make sure you don't acquire any resources---     that need releasing (exception handlers are ignored when aborting---     the transaction).  That includes doing any IO using Handles, for---     example.  Getting this wrong will probably lead to random deadlocks.------   * The transaction may have seen an inconsistent view of memory when---     the IO runs.  Invariants that you expect to be true throughout---     your program may not be true inside a transaction, due to the---     way transactions are implemented.  Normally this wouldn't be visible---     to the programmer, but using `unsafeIOToSTM` can expose it.----unsafeIOToSTM :: IO a -> STM a-unsafeIOToSTM (IO m) = STM m---- | Perform a series of STM actions atomically.------ Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'--- subverts some of guarantees that STM provides. It makes it possible to--- run a transaction inside of another transaction, depending on when the--- thunk is evaluated. If a nested transaction is attempted, an exception--- is thrown by the runtime. It is possible to safely use 'atomically' inside--- 'unsafePerformIO' or 'unsafeInterleaveIO', but the typechecker does not--- rule out programs that may attempt nested transactions, meaning that--- the programmer must take special care to prevent these.------ However, there are functions for creating transactional variables that--- can always be safely called in 'unsafePerformIO'. See: 'newTVarIO',--- 'Control.Concurrent.STM.TChan.newTChanIO',--- 'Control.Concurrent.STM.TChan.newBroadcastTChanIO',--- 'Control.Concurrent.STM.TQueue.newTQueueIO',--- 'Control.Concurrent.STM.TBQueue.newTBQueueIO', and--- 'Control.Concurrent.STM.TMVar.newTMVarIO'.------ Using 'unsafePerformIO' inside of 'atomically' is also dangerous but for--- different reasons. See 'unsafeIOToSTM' for more on this.--atomically :: STM a -> IO a-atomically (STM m) = IO (\s -> (atomically# m) s )---- | Retry execution of the current memory transaction because it has seen--- values in 'TVar's which mean that it should not continue (e.g. the 'TVar's--- represent a shared buffer that is now empty).  The implementation may--- block the thread until one of the 'TVar's that it has read from has been--- updated. (GHC only)-retry :: STM a-retry = STM $ \s# -> retry# s#---- | Compose two alternative STM actions (GHC only).------ If the first action completes without retrying then it forms the result of--- the 'orElse'. Otherwise, if the first action retries, then the second action--- is tried in its place. If both actions retry then the 'orElse' as a whole--- retries.-orElse :: STM a -> STM a -> STM a-orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s---- | A variant of 'throw' that can only be used within the 'STM' monad.------ Throwing an exception in @STM@ aborts the transaction and propagates the--- exception. If the exception is caught via 'catchSTM', only the changes--- enclosed by the catch are rolled back; changes made outside of 'catchSTM'--- persist.------ If the exception is not caught inside of the 'STM', it is re-thrown by--- 'atomically', and the entire 'STM' is rolled back.------ Although 'throwSTM' has a type that is an instance of the type of 'throw', the--- two functions are subtly different:------ > throw e    `seq` x  ===> throw e--- > throwSTM e `seq` x  ===> x------ The first example will cause the exception @e@ to be raised,--- whereas the second one won\'t.  In fact, 'throwSTM' will only cause--- an exception to be raised when it is used within the 'STM' monad.--- The 'throwSTM' variant should be used in preference to 'throw' to--- raise an exception within the 'STM' monad because it guarantees--- ordering with respect to other 'STM' operations, whereas 'throw'--- does not.-throwSTM :: Exception e => e -> STM a-throwSTM e = STM $ raiseIO# (toException e)---- | Exception handling within STM actions.------ @'catchSTM' m f@ catches any exception thrown by @m@ using 'throwSTM',--- using the function @f@ to handle the exception. If an exception is--- thrown, any changes made by @m@ are rolled back, but changes prior to--- @m@ persist.-catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a-catchSTM (STM m) handler = STM $ catchSTM# m handler'-    where-      handler' e = case fromException e of-                     Just e' -> unSTM (handler e')-                     Nothing -> raiseIO# e---- |Shared memory locations that support atomic memory transactions.-data TVar a = TVar (TVar# RealWorld a)---- | @since 4.8.0.0-instance Eq (TVar a) where-        (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#)---- | Create a new 'TVar' holding a value supplied-newTVar :: a -> STM (TVar a)-newTVar val = STM $ \s1# ->-    case newTVar# val s1# of-         (# s2#, tvar# #) -> (# s2#, TVar tvar# #)---- | @IO@ version of 'newTVar'.  This is useful for creating top-level--- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using--- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't--- possible.-newTVarIO :: a -> IO (TVar a)-newTVarIO val = IO $ \s1# ->-    case newTVar# val s1# of-         (# s2#, tvar# #) -> (# s2#, TVar tvar# #)---- | Return the current value stored in a 'TVar'.--- This is equivalent to------ >  readTVarIO = atomically . readTVar------ but works much faster, because it doesn't perform a complete--- transaction, it just reads the current value of the 'TVar'.-readTVarIO :: TVar a -> IO a-readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#---- |Return the current value stored in a 'TVar'.-readTVar :: TVar a -> STM a-readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#---- |Write the supplied value into a 'TVar'.-writeTVar :: TVar a -> a -> STM ()-writeTVar (TVar tvar#) val = STM $ \s1# ->-    case writeTVar# tvar# val s1# of-         s2# -> (# s2#, () #)---------------------------------------------------------------------------------- MVar utilities---------------------------------------------------------------------------------- | Provide an 'IO' action with the current value of an 'MVar'. The 'MVar'--- will be empty for the duration that the action is running.-withMVar :: MVar a -> (a -> IO b) -> IO b-withMVar m io =-  mask $ \restore -> do-    a <- takeMVar m-    b <- catchAny (restore (io a))-            (\e -> do putMVar m a; throw e)-    putMVar m a-    return b---- | Modify the value of an 'MVar'.-modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()-modifyMVar_ m io =-  mask $ \restore -> do-    a <- takeMVar m-    a' <- catchAny (restore (io a))-            (\e -> do putMVar m a; throw e)-    putMVar m a'-    return ()---------------------------------------------------------------------------------- Thread waiting---------------------------------------------------------------------------------- Machinery needed to ensure that we only have one copy of certain--- CAFs in this module even when the base package is present twice, as--- it is when base is dynamically loaded into GHCi.  The RTS keeps--- track of the single true value of the CAF, so even when the CAFs in--- the dynamically-loaded base package are reverted, nothing bad--- happens.----sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a-sharedCAF a get_or_set =-   mask_ $ do-     stable_ref <- newStablePtr a-     let ref = castPtr (castStablePtrToPtr stable_ref)-     ref2 <- get_or_set ref-     if ref==ref2-        then return a-        else do freeStablePtr stable_ref-                deRefStablePtr (castPtrToStablePtr (castPtr ref2))--reportStackOverflow :: IO ()-reportStackOverflow = do-     ThreadId tid <- myThreadId-     c_reportStackOverflow tid--reportError :: SomeException -> IO ()-reportError ex = do-   handler <- getUncaughtExceptionHandler-   handler ex---- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove--- the unsafe below.-foreign import ccall unsafe "reportStackOverflow"-        c_reportStackOverflow :: ThreadId# -> IO ()--foreign import ccall unsafe "reportHeapOverflow"-        reportHeapOverflow :: IO ()--{-# NOINLINE uncaughtExceptionHandler #-}-uncaughtExceptionHandler :: IORef (SomeException -> IO ())-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)-   where-      defaultHandler :: SomeException -> IO ()-      defaultHandler se@(SomeException ex) = do-         (hFlush stdout) `catchAny` (\ _ -> return ())-         let msg = case cast ex of-               Just Deadlock -> "no threads to run:  infinite loop or deadlock?"-               _                  -> showsPrec 0 se ""-         withCString "%s" $ \cfmt ->-          withCString msg $ \cmsg ->-            errorBelch cfmt cmsg---- don't use errorBelch() directly, because we cannot call varargs functions--- using the FFI.-foreign import ccall unsafe "HsBase.h errorBelch2"-   errorBelch :: CString -> CString -> IO ()--setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler--getUncaughtExceptionHandler :: IO (SomeException -> IO ())-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
− GHC/Conc/Sync.hs-boot 
@@ -1,70 +0,0 @@-{-# LANGUAGE MagicHash, NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.Sync [boot]--- 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)------ Basic concurrency stuff.-----------------------------------------------------------------------------------module GHC.Conc.Sync-        ( forkIO,-          TVar(..),-          ThreadId(..),-          myThreadId,-          showThreadId,-          ThreadStatus(..),-          threadStatus,-          sharedCAF-        ) where--import GHC.Base-import GHC.Ptr--forkIO :: IO () -> IO ThreadId--data ThreadId = ThreadId ThreadId#-data TVar a = TVar (TVar# RealWorld a)--data BlockReason-        = BlockedOnMVar-              -- ^blocked on 'MVar'-        {- possibly (see 'threadstatus' below):-        | BlockedOnMVarRead-              -- ^blocked on reading an empty 'MVar'-        -}-        | BlockedOnBlackHole-              -- ^blocked on a computation in progress by another thread-        | BlockedOnException-              -- ^blocked in 'throwTo'-        | BlockedOnSTM-              -- ^blocked in 'retry' in an STM transaction-        | BlockedOnForeignCall-              -- ^currently in a foreign call-        | BlockedOnOther-              -- ^blocked on some other resource.  Without @-threaded@,-              -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@-              -- they show up as 'BlockedOnMVar'.--data ThreadStatus-        = ThreadRunning-              -- ^the thread is currently runnable or running-        | ThreadFinished-              -- ^the thread has finished-        | ThreadBlocked  BlockReason-              -- ^the thread is blocked on some resource-        | ThreadDied-        -- ^the thread received an uncaught exception--myThreadId :: IO ThreadId-showThreadId :: ThreadId -> String-threadStatus :: ThreadId -> IO ThreadStatus-sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
− GHC/Conc/WinIO.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.WinIO--- 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)------ Windows I/O Completion Port interface to the one defined in--- GHC.Event.Windows.------ This module is an indirection to keep things in the same structure as before--- but also to keep the new code where the actual I/O manager is.  As such it--- just re-exports GHC.Event.Windows.Thread------------------------------------------------------------------------------------- #not-home-module GHC.Conc.WinIO-       ( module GHC.Event.Windows.Thread ) where--import GHC.Event.Windows.Thread
− GHC/Conc/Windows.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Conc.Windows--- 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)------ Windows I/O manager interfaces. Depending on which I/O Subsystem is used--- requests will be routed to different places.------------------------------------------------------------------------------------- #not-home-module GHC.Conc.Windows-       ( ensureIOManagerIsRunning-       , interruptIOManager--       -- * Waiting-       , threadDelay-       , registerDelay--       -- * Miscellaneous-       , asyncRead-       , asyncWrite-       , asyncDoProc--       , asyncReadBA-       , asyncWriteBA--       -- * Console event handler-       , module GHC.Event.Windows.ConsoleEvent-       ) where---#include "windows_cconv.h"--import GHC.Base-import GHC.Conc.Sync-import qualified GHC.Conc.POSIX as POSIX-import qualified GHC.Conc.WinIO as WINIO-import GHC.Event.Windows.ConsoleEvent-import GHC.IO.SubSystem ((<!>))-import GHC.Ptr---- ------------------------------------------------------------------------------- Thread waiting---- Note: threadWaitRead and threadWaitWrite aren't really functional--- on Win32, but left in there because lib code (still) uses them (the manner--- in which they're used doesn't cause problems on a Win32 platform though.)--asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)-asyncRead  (I# fd) (I# isSock) (I# len) (Ptr buf) =-  IO $ \s -> case asyncRead# fd isSock len buf s of-               (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)--asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)-asyncWrite  (I# fd) (I# isSock) (I# len) (Ptr buf) =-  IO $ \s -> case asyncWrite# fd isSock len buf s of-               (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)--asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int-asyncDoProc (FunPtr proc) (Ptr param) =-    -- the 'length' value is ignored; simplifies implementation of-    -- the async*# primops to have them all return the same result.-  IO $ \s -> case asyncDoProc# proc param s  of-               (# s', _len#, err# #) -> (# s', I# err# #)---- to aid the use of these primops by the IO Handle implementation,--- provide the following convenience funs:---- this better be a pinned byte array!-asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)-asyncReadBA fd isSock len off bufB =-  asyncRead fd isSock len ((Ptr (mutableByteArrayContents# bufB)) `plusPtr` off)--asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)-asyncWriteBA fd isSock len off bufB =-  asyncWrite fd isSock len ((Ptr (mutableByteArrayContents# bufB)) `plusPtr` off)---- ------------------------------------------------------------------------------- Threaded RTS implementation of threadDelay---- | Suspends the current thread for a given number of microseconds--- (GHC only).------ There is no guarantee that the thread will be rescheduled promptly--- when the delay has expired, but the thread will never continue to--- run /earlier/ than specified.----threadDelay :: Int -> IO ()-threadDelay = POSIX.threadDelay <!> WINIO.threadDelay---- | Set the value of returned TVar to True after a given number of--- microseconds. The caveats associated with threadDelay also apply.----registerDelay :: Int -> IO (TVar Bool)-registerDelay = POSIX.registerDelay <!> WINIO.registerDelay--ensureIOManagerIsRunning :: IO ()-ensureIOManagerIsRunning =  POSIX.ensureIOManagerIsRunning-                        <!> WINIO.ensureIOManagerIsRunning--interruptIOManager :: IO ()-interruptIOManager = POSIX.interruptIOManager <!> WINIO.interruptIOManager--
− GHC/ConsoleHandler.hsc 
@@ -1,142 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.ConsoleHandler--- Copyright   :  (c) The University of Glasgow--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ NB. the contents of this module are only available on Windows.------ Installing Win32 console handlers.-----------------------------------------------------------------------------------module GHC.ConsoleHandler-#if !defined(mingw32_HOST_OS)-        where--import GHC.Base ()  -- dummy dependency-#else /* whole file */-        ( Handler(..)-        , installHandler-        , ConsoleEvent(..)-        ) where--#include <windows.h>-{--#include "rts/Signals.h"--Note: this #include is inside a Haskell comment-      but it brings into scope some #defines-      that are used by CPP below (eg STG_SIG_DFL).-      Having it in a comment means that there's no-      danger that C-like crap will be misunderstood-      by GHC--}--import GHC.Base-import Foreign-import Foreign.C-import GHC.Conc-import Control.Concurrent.MVar--data Handler- = Default- | Ignore- | Catch (ConsoleEvent -> IO ())---- | Allows Windows console events to be caught and handled.  To--- handle a console event, call 'installHandler' passing the--- appropriate 'Handler' value.  When the event is received, if the--- 'Handler' value is @Catch f@, then a new thread will be spawned by--- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that--- was received.------ Note that console events can only be received by an application--- running in a Windows console.  Certain environments that look like consoles--- do not support console events, these include:------  * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,---    then a Cygwin shell behaves like a Windows console).---  * Cygwin xterm and rxvt windows---  * MSYS rxvt windows------ In order for your application to receive console events, avoid running--- it in one of these environments.----installHandler :: Handler -> IO Handler-installHandler handler-  | threaded =-    modifyMVar win32ConsoleHandler $ \old_h -> do-      (new_h,rc) <--        case handler of-          Default -> do-            r <- rts_installHandler STG_SIG_DFL nullPtr-            return (no_handler, r)-          Ignore  -> do-            r <- rts_installHandler STG_SIG_IGN nullPtr-            return (no_handler, r)-          Catch h -> do-            r <- rts_installHandler STG_SIG_HAN nullPtr-            return (h, r)-      prev_handler <--        case rc of-          STG_SIG_DFL -> return Default-          STG_SIG_IGN -> return Ignore-          STG_SIG_HAN -> return (Catch old_h)-          _           -> errorWithoutStackTrace "installHandler: Bad threaded rc value"-      return (new_h, prev_handler)--  | otherwise =-  alloca $ \ p_sp -> do-   rc <--    case handler of-     Default -> rts_installHandler STG_SIG_DFL p_sp-     Ignore  -> rts_installHandler STG_SIG_IGN p_sp-     Catch h -> do-        v <- newStablePtr (toHandler h)-        poke p_sp v-        rts_installHandler STG_SIG_HAN p_sp-   case rc of-     STG_SIG_DFL -> return Default-     STG_SIG_IGN -> return Ignore-     STG_SIG_HAN -> do-        osptr <- peek p_sp-        oldh  <- deRefStablePtr osptr-         -- stable pointer is no longer in use, free it.-        freeStablePtr osptr-        return (Catch (\ ev -> oldh (fromConsoleEvent ev)))-     _           -> errorWithoutStackTrace "installHandler: Bad non-threaded rc value"-  where-   fromConsoleEvent ev =-     case ev of-       ControlC -> #{const CTRL_C_EVENT       }-       Break    -> #{const CTRL_BREAK_EVENT   }-       Close    -> #{const CTRL_CLOSE_EVENT   }-       Logoff   -> #{const CTRL_LOGOFF_EVENT  }-       Shutdown -> #{const CTRL_SHUTDOWN_EVENT}--   toHandler hdlr ev = do-      case toWin32ConsoleEvent ev of-         -- see rts/win32/ConsoleHandler.c for comments as to why-         -- rts_ConsoleHandlerDone is called here.-        Just x  -> hdlr x >> rts_ConsoleHandlerDone ev-        Nothing -> return () -- silently ignore..--   no_handler = errorWithoutStackTrace "win32ConsoleHandler"--foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool--foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"-  rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt-foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"-  rts_ConsoleHandlerDone :: CInt -> IO ()--#endif /* mingw32_HOST_OS */
− GHC/Constants.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Constants where---- TODO: This used to include HaskellConstants.hs, but that has now gone.--- We probably want to include the constants in platformConstants somehow--- instead.--import GHC.Base () -- dummy dependency
− GHC/Desugar.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , RankNTypes-           , ExistentialQuantification-  #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Desugar--- Copyright   :  (c) The University of Glasgow, 2007--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Support code for desugaring in GHC-----------------------------------------------------------------------------------module GHC.Desugar ((>>>), AnnotationWrapper(..), toAnnotationWrapper) where--import Control.Arrow    (Arrow(..))-import Control.Category ((.))-import Data.Data        (Data)---- A version of Control.Category.>>> overloaded on Arrow-(>>>) :: forall arr. Arrow arr => forall a b c. arr a b -> arr b c -> arr a c--- NB: the type of this function is the "shape" that GHC expects---     in tcInstClassOp.  So don't put all the foralls at the front!---     Yes, this is a bit grotesque, but heck it works and the whole---     arrows stuff needs reworking anyway!-f >>> g = g . f-{-# INLINE (>>>) #-} -- see Note [INLINE on >>>] in Control.Category---- A wrapper data type that lets the typechecker get at the appropriate dictionaries for an annotation-data AnnotationWrapper = forall a. (Data a) => AnnotationWrapper a--toAnnotationWrapper :: (Data a) => a -> AnnotationWrapper-toAnnotationWrapper what = AnnotationWrapper what
− GHC/Enum.hs 
@@ -1,1038 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Enum--- Copyright   :  (c) The University of Glasgow, 1992-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ The 'Enum' and 'Bounded' classes.-----------------------------------------------------------------------------------#include "MachDeps.h"--module GHC.Enum(-        Bounded(..), Enum(..),-        boundedEnumFrom, boundedEnumFromThen,-        toEnumError, fromEnumError, succError, predError,--        -- Instances for Bounded and Enum: (), Char, Int--   ) where--import GHC.Base hiding ( many )-import GHC.Char-import GHC.Num.Integer-import GHC.Num-import GHC.Show-import GHC.Tuple (Solo (..))-default ()              -- Double isn't available yet---- | The 'Bounded' class is used to name the upper and lower limits of a--- type.  'Ord' is not a superclass of 'Bounded' since types that are not--- totally ordered may also have upper and lower bounds.------ The 'Bounded' class may be derived for any enumeration type;--- 'minBound' is the first constructor listed in the @data@ declaration--- and 'maxBound' is the last.--- 'Bounded' may also be derived for single-constructor datatypes whose--- constituent types are in 'Bounded'.--class  Bounded a  where-    minBound, maxBound :: a---- | Class 'Enum' defines operations on sequentially ordered types.------ The @enumFrom@... methods are used in Haskell's translation of--- arithmetic sequences.------ Instances of 'Enum' may be derived for any enumeration type (types--- whose constructors have no fields).  The nullary constructors are--- assumed to be numbered left-to-right by 'fromEnum' from @0@ through @n-1@.--- See Chapter 10 of the /Haskell Report/ for more details.------ For any type that is an instance of class 'Bounded' as well as 'Enum',--- the following should hold:------ * The calls @'succ' 'maxBound'@ and @'pred' 'minBound'@ should result in---   a runtime error.------ * 'fromEnum' and 'toEnum' should give a runtime error if the---   result value is not representable in the result type.---   For example, @'toEnum' 7 :: 'Bool'@ is an error.------ * 'enumFrom' and 'enumFromThen' should be defined with an implicit bound,---   thus:------ >    enumFrom     x   = enumFromTo     x maxBound--- >    enumFromThen x y = enumFromThenTo x y bound--- >      where--- >        bound | fromEnum y >= fromEnum x = maxBound--- >              | otherwise                = minBound----class  Enum a   where-    -- | the successor of a value.  For numeric types, 'succ' adds 1.-    succ                :: a -> a-    -- | the predecessor of a value.  For numeric types, 'pred' subtracts 1.-    pred                :: a -> a-    -- | Convert from an 'Int'.-    toEnum              :: Int -> a-    -- | Convert to an 'Int'.-    -- It is implementation-dependent what 'fromEnum' returns when-    -- applied to a value that is too large to fit in an 'Int'.-    fromEnum            :: a -> Int--    -- | Used in Haskell's translation of @[n..]@ with @[n..] = enumFrom n@,-    --   a possible implementation being @enumFrom n = n : enumFrom (succ n)@.-    --   For example:-    ---    --     * @enumFrom 4 :: [Integer] = [4,5,6,7,...]@-    --     * @enumFrom 6 :: [Int] = [6,7,8,9,...,maxBound :: Int]@-    enumFrom            :: a -> [a]-    -- | Used in Haskell's translation of @[n,n'..]@-    --   with @[n,n'..] = enumFromThen n n'@, a possible implementation being-    --   @enumFromThen n n' = n : n' : worker (f x) (f x n')@,-    --   @worker s v = v : worker s (s v)@, @x = fromEnum n' - fromEnum n@ and-    --   @f n y-    --     | n > 0 = f (n - 1) (succ y)-    --     | n < 0 = f (n + 1) (pred y)-    --     | otherwise = y@-    --   For example:-    ---    --     * @enumFromThen 4 6 :: [Integer] = [4,6,8,10...]@-    --     * @enumFromThen 6 2 :: [Int] = [6,2,-2,-6,...,minBound :: Int]@-    enumFromThen        :: a -> a -> [a]-    -- | Used in Haskell's translation of @[n..m]@ with-    --   @[n..m] = enumFromTo n m@, a possible implementation being-    --   @enumFromTo n m-    --      | n <= m = n : enumFromTo (succ n) m-    --      | otherwise = []@.-    --   For example:-    ---    --     * @enumFromTo 6 10 :: [Int] = [6,7,8,9,10]@-    --     * @enumFromTo 42 1 :: [Integer] = []@-    enumFromTo          :: a -> a -> [a]-    -- | Used in Haskell's translation of @[n,n'..m]@ with-    --   @[n,n'..m] = enumFromThenTo n n' m@, a possible implementation-    --   being @enumFromThenTo n n' m = worker (f x) (c x) n m@,-    --   @x = fromEnum n' - fromEnum n@, @c x = bool (>=) (<=) (x > 0)@-    --   @f n y-    --      | n > 0 = f (n - 1) (succ y)-    --      | n < 0 = f (n + 1) (pred y)-    --      | otherwise = y@ and-    --   @worker s c v m-    --      | c v m = v : worker s c (s v) m-    --      | otherwise = []@-    --   For example:-    ---    --     * @enumFromThenTo 4 2 -6 :: [Integer] = [4,2,0,-2,-4,-6]@-    --     * @enumFromThenTo 6 8 2 :: [Int] = []@-    enumFromThenTo      :: a -> a -> a -> [a]--    succ = toEnum . (+ 1) . fromEnum--    pred = toEnum . (subtract 1) . fromEnum--    -- See Note [Stable Unfolding for list producers]-    {-# INLINABLE enumFrom #-}-    enumFrom x = map toEnum [fromEnum x ..]--    -- See Note [Stable Unfolding for list producers]-    {-# INLINABLE enumFromThen #-}-    enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]--    -- See Note [Stable Unfolding for list producers]-    {-# INLINABLE enumFromTo #-}-    enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]--    -- See Note [Stable Unfolding for list producers]-    {-# INLINABLE enumFromThenTo #-}-    enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]---- See Note [Stable Unfolding for list producers]-{-# INLINABLE boundedEnumFrom #-}--- Default methods for bounded enumerations-boundedEnumFrom :: (Enum a, Bounded a) => a -> [a]-boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)]---- See Note [Stable Unfolding for list producers]-{-# INLINABLE boundedEnumFromThen #-}-boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a]-boundedEnumFromThen n1 n2-  | i_n2 >= i_n1  = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)]-  | otherwise     = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)]-  where-    i_n1 = fromEnum n1-    i_n2 = fromEnum n2--{--Note [Stable Unfolding for list producers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The INLINABLE/INLINE pragmas ensure that we export stable (unoptimised)-unfoldings in the interface file so we can do list fusion at usage sites.--}----------------------------------------------------------------------------- Helper functions---------------------------------------------------------------------------{-# NOINLINE toEnumError #-}-toEnumError :: (Show a) => String -> Int -> (a,a) -> b-toEnumError inst_ty i bnds =-    errorWithoutStackTrace $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++-            show i ++-            ") is outside of bounds " ++-            show bnds--{-# NOINLINE fromEnumError #-}-fromEnumError :: (Show a) => String -> a -> b-fromEnumError inst_ty x =-    errorWithoutStackTrace $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++-            show x ++-            ") is outside of Int's bounds " ++-            show (minBound::Int, maxBound::Int)--{-# NOINLINE succError #-}-succError :: String -> a-succError inst_ty =-    errorWithoutStackTrace $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"--{-# NOINLINE predError #-}-predError :: String -> a-predError inst_ty =-    errorWithoutStackTrace $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"----------------------------------------------------------------------------- Tuples----------------------------------------------------------------------------- | @since 2.01-deriving instance Bounded ()---- | @since 2.01-instance Enum () where-    succ _      = errorWithoutStackTrace "Prelude.Enum.().succ: bad argument"-    pred _      = errorWithoutStackTrace "Prelude.Enum.().pred: bad argument"--    toEnum x | x == 0    = ()-             | otherwise = errorWithoutStackTrace "Prelude.Enum.().toEnum: bad argument"--    fromEnum () = 0-    enumFrom ()         = [()]-    enumFromThen () ()  = let many = ():many in many-    enumFromTo () ()    = [()]-    enumFromThenTo () () () = let many = ():many in many--instance Enum a => Enum (Solo a) where-    succ (Solo a) = Solo (succ a)-    pred (Solo a) = Solo (pred a)--    toEnum x = Solo (toEnum x)--    fromEnum (Solo x) = fromEnum x-    enumFrom (Solo x) = [Solo a | a <- enumFrom x]-    enumFromThen (Solo x) (Solo y) =-      [Solo a | a <- enumFromThen x y]-    enumFromTo (Solo x) (Solo y) =-      [Solo a | a <- enumFromTo x y]-    enumFromThenTo (Solo x) (Solo y) (Solo z) =-      [Solo a | a <- enumFromThenTo x y z]--deriving instance Bounded a => Bounded (Solo a)--- Report requires instances up to 15--- | @since 2.01-deriving instance (Bounded a, Bounded b)-        => Bounded (a,b)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c)-        => Bounded (a,b,c)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d)-        => Bounded (a,b,c,d)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e)-        => Bounded (a,b,c,d,e)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f)-        => Bounded (a,b,c,d,e,f)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g)-        => Bounded (a,b,c,d,e,f,g)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h)-        => Bounded (a,b,c,d,e,f,g,h)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i)-        => Bounded (a,b,c,d,e,f,g,h,i)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i, Bounded j)-        => Bounded (a,b,c,d,e,f,g,h,i,j)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k)-        => Bounded (a,b,c,d,e,f,g,h,i,j,k)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k,-          Bounded l)-        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k,-          Bounded l, Bounded m)-        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k,-          Bounded l, Bounded m, Bounded n)-        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n)--- | @since 2.01-deriving instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e,-          Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k,-          Bounded l, Bounded m, Bounded n, Bounded o)-        => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)----------------------------------------------------------------------------- Bool----------------------------------------------------------------------------- | @since 2.01-deriving instance Bounded Bool---- | @since 2.01-instance Enum Bool where-  succ False = True-  succ True  = errorWithoutStackTrace "Prelude.Enum.Bool.succ: bad argument"--  pred True  = False-  pred False  = errorWithoutStackTrace "Prelude.Enum.Bool.pred: bad argument"--  toEnum n | n == 0    = False-           | n == 1    = True-           | otherwise = errorWithoutStackTrace "Prelude.Enum.Bool.toEnum: bad argument"--  fromEnum False = 0-  fromEnum True  = 1--  -- Use defaults for the rest-  enumFrom     = boundedEnumFrom-  enumFromThen = boundedEnumFromThen----------------------------------------------------------------------------- Ordering----------------------------------------------------------------------------- | @since 2.01-deriving instance Bounded Ordering--- | @since 2.01-instance Enum Ordering where-  succ LT = EQ-  succ EQ = GT-  succ GT = errorWithoutStackTrace "Prelude.Enum.Ordering.succ: bad argument"--  pred GT = EQ-  pred EQ = LT-  pred LT = errorWithoutStackTrace "Prelude.Enum.Ordering.pred: bad argument"--  toEnum n | n == 0 = LT-           | n == 1 = EQ-           | n == 2 = GT-  toEnum _ = errorWithoutStackTrace "Prelude.Enum.Ordering.toEnum: bad argument"--  fromEnum LT = 0-  fromEnum EQ = 1-  fromEnum GT = 2--  -- Use defaults for the rest-  enumFrom     = boundedEnumFrom-  enumFromThen = boundedEnumFromThen----------------------------------------------------------------------------- Char----------------------------------------------------------------------------- | @since 2.01-instance  Bounded Char  where-    minBound =  '\0'-    maxBound =  '\x10FFFF'---- | @since 2.01-instance  Enum Char  where-    succ (C# c#)-       | isTrue# (ord# c# /=# 0x10FFFF#) = C# (chr# (ord# c# +# 1#))-       | otherwise             = errorWithoutStackTrace ("Prelude.Enum.Char.succ: bad argument")-    pred (C# c#)-       | isTrue# (ord# c# /=# 0#) = C# (chr# (ord# c# -# 1#))-       | otherwise                = errorWithoutStackTrace ("Prelude.Enum.Char.pred: bad argument")--    toEnum   = chr-    fromEnum = ord--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFrom #-}-    enumFrom (C# x) = eftChar (ord# x) 0x10FFFF#-        -- Blarg: technically I guess enumFrom isn't strict!--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromTo #-}-    enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y)--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromThen #-}-    enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2)--    -- See Note [Stable Unfolding for list producers]-    {-# 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)-"efdtChar"      [~1] forall x1 x2 l.    efdtChar x1 x2 l  = build (\ c n -> efdtCharFB c n x1 x2 l)-"eftCharList"   [1]  eftCharFB  (:) [] = eftChar-"efdCharList"   [1]  efdCharFB  (:) [] = efdChar-"efdtCharList"  [1]  efdtCharFB (:) [] = efdtChar- #-}----- We can do better than for Ints because we don't--- have hassles about arithmetic overflow at maxBound-{-# INLINE [0] eftCharFB #-} -- See Note [Inline FB functions] in GHC.List-eftCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a-eftCharFB c n x0 y = go x0-                 where-                    go x | isTrue# (x ># y) = n-                         | otherwise        = C# (chr# x) `c` go (x +# 1#)--{-# NOINLINE [1] eftChar #-}-eftChar :: Int# -> Int# -> String-eftChar x y | isTrue# (x ># y ) = []-            | otherwise         = C# (chr# x) : eftChar (x +# 1#) y----- For enumFromThenTo we give up on inlining-{-# INLINE [0] efdCharFB #-} -- See Note [Inline FB functions] in GHC.List-efdCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a-efdCharFB c n x1 x2-  | isTrue# (delta >=# 0#) = go_up_char_fb c n x1 delta 0x10FFFF#-  | otherwise              = go_dn_char_fb c n x1 delta 0#-  where-    !delta = x2 -# x1--{-# NOINLINE [1] efdChar #-}-efdChar :: Int# -> Int# -> String-efdChar x1 x2-  | isTrue# (delta >=# 0#) = go_up_char_list x1 delta 0x10FFFF#-  | otherwise              = go_dn_char_list x1 delta 0#-  where-    !delta = x2 -# x1--{-# INLINE [0] efdtCharFB #-} -- See Note [Inline FB functions] in GHC.List-efdtCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a-efdtCharFB c n x1 x2 lim-  | isTrue# (delta >=# 0#) = go_up_char_fb c n x1 delta lim-  | otherwise              = go_dn_char_fb c n x1 delta lim-  where-    !delta = x2 -# x1--{-# NOINLINE [1] efdtChar #-}-efdtChar :: Int# -> Int# -> Int# -> String-efdtChar x1 x2 lim-  | isTrue# (delta >=# 0#) = go_up_char_list x1 delta lim-  | otherwise              = go_dn_char_list x1 delta lim-  where-    !delta = x2 -# x1--go_up_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a-go_up_char_fb c n x0 delta lim-  = go_up x0-  where-    go_up x | isTrue# (x ># lim) = n-            | otherwise          = C# (chr# x) `c` go_up (x +# delta)--go_dn_char_fb :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a-go_dn_char_fb c n x0 delta lim-  = go_dn x0-  where-    go_dn x | isTrue# (x <# lim) = n-            | otherwise          = C# (chr# x) `c` go_dn (x +# delta)--go_up_char_list :: Int# -> Int# -> Int# -> String-go_up_char_list x0 delta lim-  = go_up x0-  where-    go_up x | isTrue# (x ># lim) = []-            | otherwise          = C# (chr# x) : go_up (x +# delta)--go_dn_char_list :: Int# -> Int# -> Int# -> String-go_dn_char_list x0 delta lim-  = go_dn x0-  where-    go_dn x | isTrue# (x <# lim) = []-            | otherwise          = C# (chr# x) : go_dn (x +# delta)------------------------------------------------------------------------------ Int---------------------------------------------------------------------------{--Be careful about these instances.-        (a) remember that you have to count down as well as up e.g. [13,12..0]-        (b) be careful of Int overflow-        (c) remember that Int is bounded, so [1..] terminates at maxInt--}---- | @since 2.01-instance  Bounded Int where-    minBound =  minInt-    maxBound =  maxInt---- | @since 2.01-instance  Enum Int  where-    succ x-       | x == maxBound  = errorWithoutStackTrace "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"-       | otherwise      = x + 1-    pred x-       | x == minBound  = errorWithoutStackTrace "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"-       | otherwise      = x - 1--    toEnum   x = x-    fromEnum x = x--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFrom #-}-    enumFrom (I# x) = eftInt x maxInt#-        where !(I# maxInt#) = maxInt-        -- Blarg: technically I guess enumFrom isn't strict!--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromTo #-}-    enumFromTo (I# x) (I# y) = eftInt x y--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromThen #-}-    enumFromThen (I# x1) (I# x2) = efdInt x1 x2--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromThenTo #-}-    enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y----------------------------------------------------------- eftInt and eftIntFB deal with [a..b], which is the--- most common form, so we take a lot of care--- In particular, we have rules for deforestation--{-# RULES-"eftInt"        [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)-"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]-eftInt x0 y | isTrue# (x0 ># y) = []-            | otherwise         = go x0-               where-                 go x = I# x : if isTrue# (x ==# y)-                               then []-                               else go (x +# 1#)--{-# INLINE [0] eftIntFB #-} -- See Note [Inline FB functions] in GHC.List-eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r-eftIntFB c n x0 y | isTrue# (x0 ># y) = n-                  | otherwise         = go x0-                 where-                   go x = I# x `c` if isTrue# (x ==# y)-                                   then n-                                   else go (x +# 1#)-                        -- Watch out for y=maxBound; hence ==, not >-        -- Be very careful not to have more than one "c"-        -- so that when eftInfFB is inlined we can inline-        -- whatever is bound to "c"----------------------------------------------------------- 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)-"efdtIntUpList" [1]  efdtIntFB (:) [] = efdtInt- #-}--efdInt :: Int# -> Int# -> [Int]--- [x1,x2..maxInt]-efdInt x1 x2- | isTrue# (x2 >=# x1) = case maxInt of I# y -> efdtIntUp x1 x2 y- | otherwise           = case minInt of I# y -> efdtIntDn x1 x2 y--{-# NOINLINE [1] efdtInt #-}-efdtInt :: Int# -> Int# -> Int# -> [Int]--- [x1,x2..y]-efdtInt x1 x2 y- | isTrue# (x2 >=# x1) = efdtIntUp x1 x2 y- | otherwise           = efdtIntDn x1 x2 y--{-# INLINE [0] efdtIntFB #-} -- See Note [Inline FB functions] in GHC.List-efdtIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r-efdtIntFB c n x1 x2 y- | isTrue# (x2 >=# x1) = efdtIntUpFB c n x1 x2 y- | otherwise           = efdtIntDnFB c n x1 x2 y---- Requires x2 >= x1-efdtIntUp :: Int# -> Int# -> Int# -> [Int]-efdtIntUp x1 x2 y    -- Be careful about overflow!- | isTrue# (y <# x2) = if isTrue# (y <# x1) then [] else [I# x1]- | otherwise = -- Common case: x1 <= x2 <= y-               let !delta = x2 -# x1 -- >= 0-                   !y' = y -# delta  -- x1 <= y' <= y; hence y' is representable--                   -- Invariant: x <= y-                   -- Note that: z <= y' => z + delta won't overflow-                   -- so we are guaranteed not to overflow if/when we recurse-                   go_up x | isTrue# (x ># y') = [I# x]-                           | otherwise         = I# x : go_up (x +# delta)-               in I# x1 : go_up x2---- Requires x2 >= x1-{-# INLINE [0] efdtIntUpFB #-} -- See Note [Inline FB functions] in GHC.List-efdtIntUpFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r-efdtIntUpFB c n x1 x2 y    -- Be careful about overflow!- | isTrue# (y <# x2) = if isTrue# (y <# x1) then n else I# x1 `c` n- | otherwise = -- Common case: x1 <= x2 <= y-               let !delta = x2 -# x1 -- >= 0-                   !y' = y -# delta  -- x1 <= y' <= y; hence y' is representable--                   -- Invariant: x <= y-                   -- Note that: z <= y' => z + delta won't overflow-                   -- so we are guaranteed not to overflow if/when we recurse-                   go_up x | isTrue# (x ># y') = I# x `c` n-                           | otherwise         = I# x `c` go_up (x +# delta)-               in I# x1 `c` go_up x2---- Requires x2 <= x1-efdtIntDn :: Int# -> Int# -> Int# -> [Int]-efdtIntDn x1 x2 y    -- Be careful about underflow!- | isTrue# (y ># x2) = if isTrue# (y ># x1) then [] else [I# x1]- | otherwise = -- Common case: x1 >= x2 >= y-               let !delta = x2 -# x1 -- <= 0-                   !y' = y -# delta  -- y <= y' <= x1; hence y' is representable--                   -- Invariant: x >= y-                   -- Note that: z >= y' => z + delta won't underflow-                   -- so we are guaranteed not to underflow if/when we recurse-                   go_dn x | isTrue# (x <# y') = [I# x]-                           | otherwise         = I# x : go_dn (x +# delta)-   in I# x1 : go_dn x2---- Requires x2 <= x1-{-# INLINE [0] efdtIntDnFB #-} -- See Note [Inline FB functions] in GHC.List-efdtIntDnFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r-efdtIntDnFB c n x1 x2 y    -- Be careful about underflow!- | isTrue# (y ># x2) = if isTrue# (y ># x1) then n else I# x1 `c` n- | otherwise = -- Common case: x1 >= x2 >= y-               let !delta = x2 -# x1 -- <= 0-                   !y' = y -# delta  -- y <= y' <= x1; hence y' is representable--                   -- Invariant: x >= y-                   -- Note that: z >= y' => z + delta won't underflow-                   -- so we are guaranteed not to underflow if/when we recurse-                   go_dn x | isTrue# (x <# y') = I# x `c` n-                           | otherwise         = I# x `c` go_dn (x +# delta)-               in I# x1 `c` go_dn x2------------------------------------------------------------------------------ Word----------------------------------------------------------------------------- | @since 2.01-instance Bounded Word where-    minBound = 0--    -- use unboxed literals for maxBound, because GHC doesn't optimise-    -- (fromInteger 0xffffffff :: Word).-#if WORD_SIZE_IN_BITS == 32-    maxBound = W# 0xFFFFFFFF##-#elif WORD_SIZE_IN_BITS == 64-    maxBound = W# 0xFFFFFFFFFFFFFFFF##-#else-#error Unhandled value for WORD_SIZE_IN_BITS-#endif---- | @since 2.01-instance Enum Word where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word"-    toEnum i@(I# i#)-        | i >= 0        = W# (int2Word# i#)-        | otherwise     = toEnumError "Word" i (minBound::Word, maxBound::Word)-    fromEnum x@(W# x#)-        | x <= maxIntWord = I# (word2Int# x#)-        | otherwise       = fromEnumError "Word" x--    {-# INLINE enumFrom #-}-    enumFrom (W# x#)      = eftWord x# maxWord#-        where !(W# maxWord#) = maxBound-        -- Blarg: technically I guess enumFrom isn't strict!--    {-# INLINE enumFromTo #-}-    enumFromTo (W# x) (W# y) = eftWord x y--    {-# INLINE enumFromThen #-}-    enumFromThen (W# x1) (W# x2) = efdWord x1 x2--    {-# INLINE enumFromThenTo #-}-    enumFromThenTo (W# x1) (W# x2) (W# y) = efdtWord x1 x2 y--maxIntWord :: Word--- The biggest word representable as an Int-maxIntWord = W# (case maxInt of I# i -> int2Word# i)---------------------------------------------------------- eftWord and eftWordFB deal with [a..b], which is the--- most common form, so we take a lot of care--- In particular, we have rules for deforestation--{-# RULES-"eftWord"        [~1] forall x y. eftWord x y = build (\ c n -> eftWordFB c n x y)-"eftWordList"    [1] eftWordFB  (:) [] = eftWord- #-}---- The Enum rules for Word work much the same way that they do for Int.--- See Note [How the Enum rules work].--{-# NOINLINE [1] eftWord #-}-eftWord :: Word# -> Word# -> [Word]--- [x1..x2]-eftWord x0 y | isTrue# (x0 `gtWord#` y) = []-             | otherwise                = go x0-                where-                  go x = W# x : if isTrue# (x `eqWord#` y)-                                then []-                                else go (x `plusWord#` 1##)--{-# INLINE [0] eftWordFB #-} -- See Note [Inline FB functions] in GHC.List-eftWordFB :: (Word -> r -> r) -> r -> Word# -> Word# -> r-eftWordFB c n x0 y | isTrue# (x0 `gtWord#` y) = n-                   | otherwise                = go x0-                  where-                    go x = W# x `c` if isTrue# (x `eqWord#` y)-                                    then n-                                    else go (x `plusWord#` 1##)-                        -- Watch out for y=maxBound; hence ==, not >-        -- Be very careful not to have more than one "c"-        -- so that when eftInfFB is inlined we can inline-        -- whatever is bound to "c"----------------------------------------------------------- efdWord and efdtWord deal with [a,b..] and [a,b..c].--- The code is more complicated because of worries about Word overflow.---- See Note [How the Enum rules work]-{-# RULES-"efdtWord"       [~1] forall x1 x2 y.-                     efdtWord x1 x2 y = build (\ c n -> efdtWordFB c n x1 x2 y)-"efdtWordUpList" [1]  efdtWordFB (:) [] = efdtWord- #-}--efdWord :: Word# -> Word# -> [Word]--- [x1,x2..maxWord]-efdWord x1 x2- | isTrue# (x2 `geWord#` x1) = case maxBound of W# y -> efdtWordUp x1 x2 y- | otherwise                 = case minBound of W# y -> efdtWordDn x1 x2 y--{-# NOINLINE [1] efdtWord #-}-efdtWord :: Word# -> Word# -> Word# -> [Word]--- [x1,x2..y]-efdtWord x1 x2 y- | isTrue# (x2 `geWord#` x1) = efdtWordUp x1 x2 y- | otherwise                 = efdtWordDn x1 x2 y--{-# INLINE [0] efdtWordFB #-} -- See Note [Inline FB functions] in GHC.List-efdtWordFB :: (Word -> r -> r) -> r -> Word# -> Word# -> Word# -> r-efdtWordFB c n x1 x2 y- | isTrue# (x2 `geWord#` x1) = efdtWordUpFB c n x1 x2 y- | otherwise                 = efdtWordDnFB c n x1 x2 y---- Requires x2 >= x1-efdtWordUp :: Word# -> Word# -> Word# -> [Word]-efdtWordUp x1 x2 y    -- Be careful about overflow!- | isTrue# (y `ltWord#` x2) = if isTrue# (y `ltWord#` x1) then [] else [W# x1]- | otherwise = -- Common case: x1 <= x2 <= y-               let !delta = x2 `minusWord#` x1 -- >= 0-                   !y' = y `minusWord#` delta  -- x1 <= y' <= y; hence y' is representable--                   -- Invariant: x <= y-                   -- Note that: z <= y' => z + delta won't overflow-                   -- so we are guaranteed not to overflow if/when we recurse-                   go_up x | isTrue# (x `gtWord#` y') = [W# x]-                           | otherwise                = W# x : go_up (x `plusWord#` delta)-               in W# x1 : go_up x2---- Requires x2 >= x1-{-# INLINE [0] efdtWordUpFB #-} -- See Note [Inline FB functions] in GHC.List-efdtWordUpFB :: (Word -> r -> r) -> r -> Word# -> Word# -> Word# -> r-efdtWordUpFB c n x1 x2 y    -- Be careful about overflow!- | isTrue# (y `ltWord#` x2) = if isTrue# (y `ltWord#` x1) then n else W# x1 `c` n- | otherwise = -- Common case: x1 <= x2 <= y-               let !delta = x2 `minusWord#` x1 -- >= 0-                   !y' = y `minusWord#` delta  -- x1 <= y' <= y; hence y' is representable--                   -- Invariant: x <= y-                   -- Note that: z <= y' => z + delta won't overflow-                   -- so we are guaranteed not to overflow if/when we recurse-                   go_up x | isTrue# (x `gtWord#` y') = W# x `c` n-                           | otherwise                = W# x `c` go_up (x `plusWord#` delta)-               in W# x1 `c` go_up x2---- Requires x2 <= x1-efdtWordDn :: Word# -> Word# -> Word# -> [Word]-efdtWordDn x1 x2 y    -- Be careful about underflow!- | isTrue# (y `gtWord#` x2) = if isTrue# (y `gtWord#` x1) then [] else [W# x1]- | otherwise = -- Common case: x1 >= x2 >= y-               let !delta = x2 `minusWord#` x1 -- <= 0-                   !y' = y `minusWord#` delta  -- y <= y' <= x1; hence y' is representable--                   -- Invariant: x >= y-                   -- Note that: z >= y' => z + delta won't underflow-                   -- so we are guaranteed not to underflow if/when we recurse-                   go_dn x | isTrue# (x `ltWord#` y') = [W# x]-                           | otherwise                = W# x : go_dn (x `plusWord#` delta)-   in W# x1 : go_dn x2---- Requires x2 <= x1-{-# INLINE [0] efdtWordDnFB #-} -- See Note [Inline FB functions] in GHC.List-efdtWordDnFB :: (Word -> r -> r) -> r -> Word# -> Word# -> Word# -> r-efdtWordDnFB c n x1 x2 y    -- Be careful about underflow!- | isTrue# (y `gtWord#` x2) = if isTrue# (y `gtWord#` x1) then n else W# x1 `c` n- | otherwise = -- Common case: x1 >= x2 >= y-               let !delta = x2 `minusWord#` x1 -- <= 0-                   !y' = y `minusWord#` delta  -- y <= y' <= x1; hence y' is representable--                   -- Invariant: x >= y-                   -- Note that: z >= y' => z + delta won't underflow-                   -- so we are guaranteed not to underflow if/when we recurse-                   go_dn x | isTrue# (x `ltWord#` y') = W# x `c` n-                           | otherwise                = W# x `c` go_dn (x `plusWord#` delta)-               in W# x1 `c` go_dn x2----------------------------------------------------------------------------- Integer----------------------------------------------------------------------------- | @since 2.01-instance  Enum Integer  where-    succ x               = x + 1-    pred x               = x - 1-    toEnum (I# n)        = IS n-    fromEnum n           = integerToInt n--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFrom #-}-    enumFrom x = enumDeltaInteger x 1--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromThen #-}-    enumFromThen x y = enumDeltaInteger x (y-x)--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromTo #-}-    enumFromTo x lim = enumDeltaToInteger x 1 lim--    -- See Note [Stable Unfolding for list producers]-    {-# INLINE enumFromThenTo #-}-    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 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.--}--{-# INLINE [0] enumDeltaIntegerFB #-}--- See Note [Inline FB functions] in GHC.List-enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b-enumDeltaIntegerFB c x0 d = go x0-  where go x = x `seq` (x `c` go (x+d))--{-# NOINLINE [1] enumDeltaInteger #-}-enumDeltaInteger :: Integer -> Integer -> [Integer]-enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d)--- strict accumulator, so---     head (drop 1000000 [1 .. ]--- works--{-# INLINE [0] enumDeltaToIntegerFB #-}--- See Note [Inline FB functions] in GHC.List--- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire-enumDeltaToIntegerFB :: (Integer -> a -> a) -> a-                     -> Integer -> Integer -> Integer -> a-enumDeltaToIntegerFB c n x delta lim-  | delta >= 0 = up_fb c n x delta lim-  | otherwise  = dn_fb c n x delta lim--{-# INLINE [0] enumDeltaToInteger1FB #-}--- See Note [Inline FB functions] in GHC.List--- 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)-                      where-                        go x | x > lim   = n-                             | otherwise = x `c` go (x+delta)-dn_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a-dn_fb c n x0 delta lim = go (x0 :: Integer)-                      where-                        go x | x < lim   = n-                             | otherwise = x `c` go (x+delta)--up_list :: Integer -> Integer -> Integer -> [Integer]-up_list x0 delta lim = go (x0 :: Integer)-                    where-                        go x | x > lim   = []-                             | otherwise = x : go (x+delta)-dn_list :: Integer -> Integer -> Integer -> [Integer]-dn_list x0 delta lim = go (x0 :: Integer)-                    where-                        go x | x < lim   = []-                             | otherwise = x : go (x+delta)----------------------------------------------------------------------------- Natural----------------------------------------------------------------------------- | @since 4.8.0.0-instance Enum Natural where-    succ n = n + 1-    pred n = n - 1-    toEnum i@(I# i#)-      | i >= 0    = naturalFromWord# (int2Word# i#)-      | otherwise = errorWithoutStackTrace "toEnum: unexpected negative Int"--    fromEnum (NS w)-      | i >= 0    = i-      | otherwise = errorWithoutStackTrace "fromEnum: out of Int range"-      where-        i = I# (word2Int# w)-    fromEnum n = fromEnum (integerFromNatural n)--    enumFrom x        = enumDeltaNatural      x 1-    enumFromThen x y-      | x <= y        = enumDeltaNatural      x (y-x)-      | otherwise     = enumNegDeltaToNatural x (x-y) 0--    enumFromTo x lim  = enumDeltaToNatural    x 1 lim-    enumFromThenTo x y lim-      | x <= y        = enumDeltaToNatural    x (y-x) lim-      | otherwise     = enumNegDeltaToNatural x (x-y) lim---- Helpers for 'Enum Natural'; TODO: optimise & make fusion work--enumDeltaNatural :: Natural -> Natural -> [Natural]-enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d--enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural]-enumDeltaToNatural x0 delta lim = go x0-  where-    go x | x > lim   = []-         | otherwise = x : go (x+delta)--enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural]-enumNegDeltaToNatural x0 ndelta lim = go x0-  where-    go x | x < lim     = []-         | x >= ndelta = x : go (x-ndelta)-         | otherwise   = [x]----- Instances from GHC.Types---- | @since 4.16.0.0-deriving instance Bounded Levity--- | @since 4.16.0.0-deriving instance Enum Levity---- | @since 4.10.0.0-deriving instance Bounded VecCount--- | @since 4.10.0.0-deriving instance Enum VecCount---- | @since 4.10.0.0-deriving instance Bounded VecElem--- | @since 4.10.0.0-deriving instance Enum VecElem
− GHC/Environment.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-}--module GHC.Environment (getFullArgs) where--import Foreign-import Foreign.C-import GHC.Base-import GHC.Real ( fromIntegral )-import GHC.IO.Encoding-import qualified GHC.Foreign as GHC--#if defined(mingw32_HOST_OS)-# if defined(i386_HOST_ARCH)-#  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-#  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif-#endif---- | Computation 'getFullArgs' is the "raw" version of--- 'System.Environment.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]-getFullArgs =-  alloca $ \ p_argc ->-    alloca $ \ p_argv -> do-        getFullProgArgv p_argc p_argv-        p    <- fromIntegral `liftM` peek p_argc-        argv <- peek p_argv-        enc <- argvEncoding-        peekArray p argv >>= mapM (GHC.peekCString enc)--foreign import ccall unsafe "getFullProgArgv"-    getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
− GHC/Err.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-}-{-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Err--- 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)------ The "GHC.Err" module defines the code for the wired-in error functions,--- which have a special type in the compiler (with \"open tyvars\").------ We cannot define these functions in a module where they might be used--- (e.g., "GHC.Base"), because the magical wired-in type will get confused--- with what the typechecker figures out.-----------------------------------------------------------------------------------module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where-import GHC.Types (Char, RuntimeRep)-import GHC.Stack.Types-import GHC.Prim-import {-# SOURCE #-} GHC.Exception-  ( errorCallWithCallStackException-  , errorCallException )---- | 'error' stops execution and displays an error message.-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 = raise# (errorCallException 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 :: 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 = errorWithoutStackTrace "Oops! The program has entered an `absent' argument!\n"
− GHC/Event.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---- ------------------------------------------------------------------------------- | This module provides scalable event notification for file--- descriptors and timeouts.------ This module should be considered GHC internal.------ ------------------------------------------------------------------------------module GHC.Event-    ( -- * Types-      EventManager-    , TimerManager--      -- * Creation-    , getSystemEventManager-    , new-    , getSystemTimerManager--      -- * Registering interest in I/O events-    , Event-    , evtRead-    , evtWrite-    , IOCallback-    , FdKey(keyFd)-    , Lifetime(..)-    , registerFd-    , unregisterFd-    , unregisterFd_-    , closeFd--      -- * Registering interest in timeout events-    , TimeoutCallback-    , TimeoutKey-    , registerTimeout-    , updateTimeout-    , unregisterTimeout-    ) where--import GHC.Event.Manager-import GHC.Event.TimerManager (TimeoutCallback, TimeoutKey, registerTimeout,-                               updateTimeout, unregisterTimeout, TimerManager)-import GHC.Event.Thread (getSystemEventManager, getSystemTimerManager)-
− GHC/Event/Arr.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}--module GHC.Event.Arr-    (-      Arr(..)-    , new-    , size-    , read-    , write-    ) where--import GHC.Base (($))-import GHC.Prim (MutableArray#, RealWorld, newArray#, readArray#,-                 sizeofMutableArray#, writeArray#)-import GHC.Types (IO(..), Int(..))--data Arr a = Arr (MutableArray# RealWorld a)--new :: a -> Int -> IO (Arr a)-new defval (I# n#) = IO $ \s0# ->-  case newArray# n# defval s0# of (# s1#, marr# #) -> (# s1#, Arr marr# #)--size :: Arr a -> Int-size (Arr a) = I# (sizeofMutableArray# a)--read :: Arr a -> Int -> IO a-read (Arr a) (I# n#) = IO $ \s0# ->-  case readArray# a n# s0# of (# s1#, val #) -> (# s1#, val #)--write :: Arr a -> Int -> a -> IO ()-write (Arr a) (I# n#) val = IO $ \s0# ->-  case writeArray# a n# val s0# of s1# -> (# s1#, () #)
− GHC/Event/Array.hs 
@@ -1,329 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns, CPP, NoImplicitPrelude #-}--module GHC.Event.Array-    (-      Array-    , capacity-    , clear-    , concat-    , copy-    , duplicate-    , empty-    , ensureCapacity-    , findIndex-    , forM_-    , length-    , loop-    , new-    , removeAt-    , snoc-    , unsafeLoad-    , unsafeCopyFromBuffer-    , unsafeRead-    , unsafeWrite-    , useAsPtr-    ) where--import Data.Bits ((.|.), shiftR)-import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)-import Data.Maybe-import Foreign.C.Types (CSize(..))-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import Foreign.Ptr (Ptr, nullPtr, plusPtr)-import Foreign.Storable (Storable(..))-import GHC.Base hiding (empty)-import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_, unsafeWithForeignPtr)-import GHC.Num (Num(..))-import GHC.Real (fromIntegral)-import GHC.Show (show)--#include "MachDeps.h"--#define BOUNDS_CHECKING 1--#if defined(BOUNDS_CHECKING)--- 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 errorWithoutStackTrace ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else-#else-#define CHECK_BOUNDS(_func_,_len_,_k_)-#endif---- Invariant: size <= capacity-newtype Array a = Array (IORef (AC a))---- The actual array content.-data AC a = AC-    !(ForeignPtr a)  -- Elements-    !Int      -- Number of elements (length)-    !Int      -- Maximum number of elements (capacity)--empty :: IO (Array a)-empty = do-  p <- newForeignPtr_ nullPtr-  Array `fmap` newIORef (AC p 0 0)--allocArray :: Storable a => Int -> IO (ForeignPtr a)-allocArray n = allocHack undefined- where-  allocHack :: Storable a => a -> IO (ForeignPtr a)-  allocHack dummy = mallocPlainForeignPtrBytes (n * sizeOf dummy)--reallocArray :: Storable a => ForeignPtr a -> Int -> Int -> IO (ForeignPtr a)-reallocArray p newSize oldSize = reallocHack undefined p- where-  reallocHack :: Storable a => a -> ForeignPtr a -> IO (ForeignPtr a)-  reallocHack dummy src = do-      let size = sizeOf dummy-      dst <- mallocPlainForeignPtrBytes (newSize * size)-      unsafeWithForeignPtr src $ \s ->-        when (s /= nullPtr && oldSize > 0) .-          unsafeWithForeignPtr dst $ \d -> do-            _ <- memcpy d s (fromIntegral (oldSize * size))-            return ()-      return dst--new :: Storable a => Int -> IO (Array a)-new c = do-    es <- allocArray cap-    fmap Array (newIORef (AC es 0 cap))-  where-    cap = firstPowerOf2 c--duplicate :: Storable a => Array a -> IO (Array a)-duplicate a = dupHack undefined a- where-  dupHack :: Storable b => b -> Array b -> IO (Array b)-  dupHack dummy (Array ref) = do-    AC es len cap <- readIORef ref-    ary <- allocArray cap-    unsafeWithForeignPtr ary $ \dest ->-      unsafeWithForeignPtr es $ \src -> do-        _ <- memcpy dest src (fromIntegral (len * sizeOf dummy))-        return ()-    Array `fmap` newIORef (AC ary len cap)--length :: Array a -> IO Int-length (Array ref) = do-    AC _ len _ <- readIORef ref-    return len--capacity :: Array a -> IO Int-capacity (Array ref) = do-    AC _ _ cap <- readIORef ref-    return cap--unsafeRead :: Storable a => Array a -> Int -> IO a-unsafeRead (Array ref) ix = do-    AC es _ cap <- readIORef ref-    CHECK_BOUNDS("unsafeRead",cap,ix)-      unsafeWithForeignPtr es $ \ptr -> peekElemOff ptr ix-        -- this is safe WRT #17760 as we assume that peekElemOff doesn't diverge--unsafeWrite :: Storable a => Array a -> Int -> a -> IO ()-unsafeWrite (Array ref) ix a = do-    ac <- readIORef ref-    unsafeWrite' ac ix a--unsafeWrite' :: Storable a => AC a -> Int -> a -> IO ()-unsafeWrite' (AC es _ cap) ix a =-    CHECK_BOUNDS("unsafeWrite'",cap,ix)-      unsafeWithForeignPtr es $ \ptr -> pokeElemOff ptr ix a-        -- this is safe WRT #17760 as we assume that peekElemOff doesn't diverge---- | Precondition: continuation must not diverge due to use of--- 'unsafeWithForeignPtr'.-unsafeLoad :: Array a -> (Ptr a -> Int -> IO Int) -> IO Int-unsafeLoad (Array ref) load = do-    AC es _ cap <- readIORef ref-    len' <- unsafeWithForeignPtr es $ \p -> load p cap-    writeIORef ref (AC es len' cap)-    return len'---- | Reads n elements from the pointer and copies them--- into the array.-unsafeCopyFromBuffer :: Storable a => Array a -> Ptr a -> Int -> IO ()-unsafeCopyFromBuffer (Array ref) sptr n =-    readIORef ref >>= \(AC es _ cap) ->-    CHECK_BOUNDS("unsafeCopyFromBuffer", cap, n)-    unsafeWithForeignPtr es $ \pdest -> do-      let size = sizeOfPtr sptr undefined-      _ <- memcpy pdest sptr (fromIntegral $ n * size)-      writeIORef ref (AC es n cap)-  where-    sizeOfPtr :: Storable a => Ptr a -> a -> Int-    sizeOfPtr _ a = sizeOf a--ensureCapacity :: Storable a => Array a -> Int -> IO ()-ensureCapacity (Array ref) c = do-    ac@(AC _ _ cap) <- readIORef ref-    ac'@(AC _ _ cap') <- ensureCapacity' ac c-    when (cap' /= cap) $-      writeIORef ref ac'--ensureCapacity' :: Storable a => AC a -> Int -> IO (AC a)-ensureCapacity' ac@(AC es len cap) c =-    if c > cap-      then do-        es' <- reallocArray es cap' cap-        return (AC es' len cap')-      else-        return ac-  where-    cap' = firstPowerOf2 c--useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b-useAsPtr (Array ref) f = do-    AC es len _ <- readIORef ref-    withForeignPtr es $ \p -> f p len--snoc :: Storable a => Array a -> a -> IO ()-snoc (Array ref) e = do-    ac@(AC _ len _) <- readIORef ref-    let len' = len + 1-    ac'@(AC es _ cap) <- ensureCapacity' ac len'-    unsafeWrite' ac' len e-    writeIORef ref (AC es len' cap)--clear :: Array a -> IO ()-clear (Array ref) =-  atomicModifyIORef' ref $ \(AC es _ cap) ->-        (AC es 0 cap, ())--forM_ :: Storable a => Array a -> (a -> IO ()) -> IO ()-forM_ ary g = forHack ary g undefined-  where-    forHack :: Storable b => Array b -> (b -> IO ()) -> b -> IO ()-    forHack (Array ref) f dummy = do-      AC es len _ <- readIORef ref-      let size = sizeOf dummy-          offset = len * size-      unsafeWithForeignPtr es $ \p -> do-        let go n | n >= offset = return ()-                 | otherwise = do-              f =<< peek (p `plusPtr` n)-              go (n + size)-        go 0--loop :: Storable a => Array a -> b -> (b -> a -> IO (b,Bool)) -> IO ()-loop ary z g = loopHack ary z g undefined-  where-    loopHack :: Storable b => Array b -> c -> (c -> b -> IO (c,Bool)) -> b-             -> IO ()-    loopHack (Array ref) y f dummy = do-      AC es len _ <- readIORef ref-      let size = sizeOf dummy-          offset = len * size-      withForeignPtr es $ \p -> do-        let go n k-                | n >= offset = return ()-                | otherwise = do-                      (k',cont) <- f k =<< peek (p `plusPtr` n)-                      when cont $ go (n + size) k'-        go 0 y--findIndex :: Storable a => (a -> Bool) -> Array a -> IO (Maybe (Int,a))-findIndex = findHack undefined- where-  findHack :: Storable b => b -> (b -> Bool) -> Array b -> IO (Maybe (Int,b))-  findHack dummy p (Array ref) = do-    AC es len _ <- readIORef ref-    let size   = sizeOf dummy-        offset = len * size-    withForeignPtr es $ \ptr ->-      let go !n !i-            | n >= offset = return Nothing-            | otherwise = do-                val <- peek (ptr `plusPtr` n)-                if p val-                  then return $ Just (i, val)-                  else go (n + size) (i + 1)-      in  go 0 0--concat :: Storable a => Array a -> Array a -> IO ()-concat (Array d) (Array s) = do-  da@(AC _ dlen _) <- readIORef d-  sa@(AC _ slen _) <- readIORef s-  writeIORef d =<< copy' da dlen sa 0 slen---- | Copy part of the source array into the destination array. The--- destination array is resized if not large enough.-copy :: Storable a => Array a -> Int -> Array a -> Int -> Int -> IO ()-copy (Array d) dstart (Array s) sstart maxCount = do-  da <- readIORef d-  sa <- readIORef s-  writeIORef d =<< copy' da dstart sa sstart maxCount---- | Copy part of the source array into the destination array. The--- destination array is resized if not large enough.-copy' :: Storable a => AC a -> Int -> AC a -> Int -> Int -> IO (AC a)-copy' d dstart s sstart maxCount = copyHack d s undefined- where-  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) $ errorWithoutStackTrace "copy: bad offsets or lengths"-    let size = sizeOf dummy-        count = min maxCount (slen - sstart)-    if count == 0-      then return dac-      else do-        AC dst dlen dcap <- ensureCapacity' dac (dstart + count)-        unsafeWithForeignPtr dst $ \dptr ->-          unsafeWithForeignPtr src $ \sptr -> do-            _ <- memcpy (dptr `plusPtr` (dstart * size))-                        (sptr `plusPtr` (sstart * size))-                        (fromIntegral (count * size))-            return $ AC dst (max dlen (dstart + count)) dcap--removeAt :: Storable a => Array a -> Int -> IO ()-removeAt a i = removeHack a undefined- where-  removeHack :: Storable b => Array b -> b -> IO ()-  removeHack (Array ary) dummy = do-    AC fp oldLen cap <- readIORef ary-    when (i < 0 || i >= oldLen) $ errorWithoutStackTrace "removeAt: invalid index"-    let size   = sizeOf dummy-        newLen = oldLen - 1-    when (newLen > 0 && i < newLen) .-      unsafeWithForeignPtr fp $ \ptr -> do-        _ <- memmove (ptr `plusPtr` (size * i))-                     (ptr `plusPtr` (size * (i+1)))-                     (fromIntegral (size * (newLen-i)))-        return ()-    writeIORef ary (AC fp newLen cap)--{-The firstPowerOf2 function works by setting all bits on the right-hand-side of the most significant flagged bit to 1, and then incrementing-the entire value at the end so it "rolls over" to the nearest power of-two.--}---- | Computes the next-highest power of two for a particular integer,--- @n@.  If @n@ is already a power of two, returns @n@.  If @n@ is--- zero, returns zero, even though zero is not a power of two.-firstPowerOf2 :: Int -> Int-firstPowerOf2 !n =-    let !n1 = n - 1-        !n2 = n1 .|. (n1 `shiftR` 1)-        !n3 = n2 .|. (n2 `shiftR` 2)-        !n4 = n3 .|. (n3 `shiftR` 4)-        !n5 = n4 .|. (n4 `shiftR` 8)-        !n6 = n5 .|. (n5 `shiftR` 16)-#if WORD_SIZE_IN_BITS == 32-    in n6 + 1-#elif WORD_SIZE_IN_BITS == 64-        !n7 = n6 .|. (n6 `shiftR` 32)-    in n7 + 1-#else-# error firstPowerOf2 not defined on this architecture-#endif--foreign import ccall unsafe "string.h memcpy"-    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)--foreign import ccall unsafe "string.h memmove"-    memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)-
− GHC/Event/Control.hs 
@@ -1,233 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , ScopedTypeVariables-           , BangPatterns-  #-}--module GHC.Event.Control-    (-    -- * Managing the IO manager-      Signal-    , ControlMessage(..)-    , Control-    , newControl-    , closeControl-    -- ** Control message reception-    , readControlMessage-    -- *** File descriptors-    , controlReadFd-    , controlWriteFd-    , wakeupReadFd-    -- ** Control message sending-    , sendWakeup-    , sendDie-    -- * Utilities-    , setNonBlockingFD-    ) where--#include "EventConfig.h"--import GHC.Base-import GHC.IORef-import GHC.Conc.Signal (Signal)-import GHC.Real (fromIntegral)-import GHC.Show (Show)-import GHC.Word (Word8)-import Foreign.C.Error (throwErrnoIfMinus1_, throwErrno, getErrno)-import Foreign.C.Types (CInt(..), CSize(..))-import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)-import Foreign.Marshal (alloca, allocaBytes)-import Foreign.Marshal.Array (allocaArray)-import Foreign.Ptr (castPtr)-import Foreign.Storable (peek, peekElemOff, poke)-import System.Posix.Internals (c_close, c_pipe, c_read, c_write,-                               setCloseOnExec, setNonBlockingFD)-import System.Posix.Types (Fd)--#if defined(HAVE_EVENTFD)-import Foreign.C.Error (throwErrnoIfMinus1, eBADF)-import Foreign.C.Types (CULLong(..))-#else-import Foreign.C.Error (eAGAIN, eWOULDBLOCK)-#endif--data ControlMessage = CMsgWakeup-                    | CMsgDie-                    | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)-                                 {-# UNPACK #-} !Signal-    deriving ( Eq   -- ^ @since 4.4.0.0-             , Show -- ^ @since 4.4.0.0-             )---- | The structure used to tell the IO manager thread what to do.-data Control = W {-      controlReadFd  :: {-# UNPACK #-} !Fd-    , controlWriteFd :: {-# UNPACK #-} !Fd-#if defined(HAVE_EVENTFD)-    , controlEventFd :: {-# UNPACK #-} !Fd-#else-    , wakeupReadFd   :: {-# UNPACK #-} !Fd-    , wakeupWriteFd  :: {-# UNPACK #-} !Fd-#endif-    , didRegisterWakeupFd :: !Bool-      -- | Have this Control's fds been cleaned up?-    , controlIsDead  :: !(IORef Bool)-    }--#if defined(HAVE_EVENTFD)-wakeupReadFd :: Control -> Fd-wakeupReadFd = controlEventFd-{-# INLINE wakeupReadFd #-}-#endif---- | Create the structure (usually a pipe) used for waking up the IO--- manager thread from another thread.-newControl :: Bool -> IO Control-newControl shouldRegister = allocaArray 2 $ \fds -> do-  let createPipe = do-        throwErrnoIfMinus1_ "pipe" $ c_pipe fds-        rd <- peekElemOff fds 0-        wr <- peekElemOff fds 1-        -- The write end must be non-blocking, since we may need to-        -- poke the event manager from a signal handler.-        setNonBlockingFD wr True-        setCloseOnExec rd-        setCloseOnExec wr-        return (rd, wr)-  (ctrl_rd, ctrl_wr) <- createPipe-#if defined(HAVE_EVENTFD)-  ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0-  setNonBlockingFD ev True-  setCloseOnExec ev-  when shouldRegister $ c_setIOManagerWakeupFd ev-#else-  (wake_rd, wake_wr) <- createPipe-  when shouldRegister $ c_setIOManagerWakeupFd wake_wr-#endif-  isDead <- newIORef False-  return W { controlReadFd  = fromIntegral ctrl_rd-           , controlWriteFd = fromIntegral ctrl_wr-#if defined(HAVE_EVENTFD)-           , controlEventFd = fromIntegral ev-#else-           , wakeupReadFd   = fromIntegral wake_rd-           , wakeupWriteFd  = fromIntegral wake_wr-#endif-           , didRegisterWakeupFd = shouldRegister-           , controlIsDead  = isDead-           }---- | Close the control structure used by the IO manager thread.--- N.B. If this Control is the Control whose wakeup file was registered with--- the RTS, then *BEFORE* the wakeup file is closed, we must call--- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup--- file after it has been closed.------ Note, however, that even if we do the above, this function is still racy--- since we do not synchronize between here and ioManagerWakeup.--- ioManagerWakeup ignores failures that arise from this case.-closeControl :: Control -> IO ()-closeControl w = do-  _ <- atomicSwapIORef (controlIsDead w) True-  _ <- c_close . fromIntegral . controlReadFd $ w-  _ <- c_close . fromIntegral . controlWriteFd $ w-  when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)-#if defined(HAVE_EVENTFD)-  _ <- c_close . fromIntegral . controlEventFd $ w-#else-  _ <- c_close . fromIntegral . wakeupReadFd $ w-  _ <- c_close . fromIntegral . wakeupWriteFd $ w-#endif-  return ()--io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8-io_MANAGER_WAKEUP = 0xff-io_MANAGER_DIE    = 0xfe--foreign import ccall "__hscore_sizeof_siginfo_t"-    sizeof_siginfo_t :: CSize--readControlMessage :: Control -> Fd -> IO ControlMessage-readControlMessage ctrl fd-    | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do-                    throwErrnoIfMinus1_ "readWakeupMessage" $-                      c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)-                    return CMsgWakeup-    | otherwise =-        alloca $ \p -> do-            throwErrnoIfMinus1_ "readControlMessage" $-                c_read (fromIntegral fd) p 1-            s <- peek p-            case s of-                -- Wakeup messages shouldn't be sent on the control-                -- file descriptor but we handle them anyway.-                _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup-                _ | s == io_MANAGER_DIE    -> return CMsgDie-                _ -> do  -- Signal-                    fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)-                    withForeignPtr fp $ \p_siginfo -> do-                        r <- c_read (fromIntegral fd) (castPtr p_siginfo)-                             sizeof_siginfo_t-                        when (r /= fromIntegral sizeof_siginfo_t) $-                            errorWithoutStackTrace "failed to read siginfo_t"-                        let !s' = fromIntegral s-                        return $ CMsgSignal fp s'--  where wakeupBufferSize =-#if defined(HAVE_EVENTFD)-            8-#else-            4096-#endif--sendWakeup :: Control -> IO ()-#if defined(HAVE_EVENTFD)-sendWakeup c = do-  n <- c_eventfd_write (fromIntegral (controlEventFd c)) 1-  case n of-    0     -> return ()-    _     -> do errno <- getErrno-                -- Check that Control is still alive if we failed, since it's-                -- possible that someone cleaned up the fds behind our backs and-                -- consequently eventfd_write failed with EBADF. If it is dead-                -- then just swallow the error since we are shutting down-                -- anyways. Otherwise we will see failures during shutdown from-                -- setnumcapabilities001 (#12038)-                isDead <- readIORef (controlIsDead c)-                if isDead && errno == eBADF-                  then return ()-                  else throwErrno "sendWakeup"-#else-sendWakeup c = do-  n <- sendMessage (wakeupWriteFd c) CMsgWakeup-  case n of-    _ | n /= -1   -> return ()-      | otherwise -> do-                   errno <- getErrno-                   when (errno /= eAGAIN && errno /= eWOULDBLOCK) $-                     throwErrno "sendWakeup"-#endif--sendDie :: Control -> IO ()-sendDie c = throwErrnoIfMinus1_ "sendDie" $-            sendMessage (controlWriteFd c) CMsgDie--sendMessage :: Fd -> ControlMessage -> IO Int-sendMessage fd msg = alloca $ \p -> do-  case msg of-    CMsgWakeup        -> poke p io_MANAGER_WAKEUP-    CMsgDie           -> poke p io_MANAGER_DIE-    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)-foreign import ccall unsafe "sys/eventfd.h eventfd"-   c_eventfd :: CInt -> CInt -> IO CInt--foreign import ccall unsafe "sys/eventfd.h eventfd_write"-   c_eventfd_write :: CInt -> CULLong -> IO CInt-#endif--foreign import ccall unsafe "setIOManagerWakeupFd"-   c_setIOManagerWakeupFd :: CInt -> IO ()
− GHC/Event/EPoll.hsc 
@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE Trustworthy                #-}---------------------------------------------------------------------------------- |--- A binding to the epoll I/O event notification facility------ epoll is a variant of poll that can be used either as an edge-triggered or--- a level-triggered interface and scales well to large numbers of watched file--- descriptors.------ epoll decouples monitor an fd from the process of registering it.-----------------------------------------------------------------------------------module GHC.Event.EPoll-    (-      new-    , available-    ) where--import qualified GHC.Event.Internal as E--#include "EventConfig.h"-#if !defined(HAVE_EPOLL)-import GHC.Base--new :: IO E.Backend-new = errorWithoutStackTrace "EPoll back end not implemented for this platform"--available :: Bool-available = False-{-# INLINE available #-}-#else--#include <sys/epoll.h>--import Data.Bits (Bits, FiniteBits, (.|.), (.&.))-import Data.Word (Word32)-import Foreign.C.Error (eNOENT, getErrno, throwErrno,-                        throwErrnoIfMinus1, throwErrnoIfMinus1_)-import Foreign.C.Types (CInt(..))-import Foreign.Marshal.Utils (with)-import Foreign.Ptr (Ptr)-import Foreign.Storable (Storable(..))-import GHC.Base-import GHC.Num (Num(..))-import GHC.Real (fromIntegral, div)-import GHC.Show (Show)-import System.Posix.Internals (c_close, setCloseOnExec)-import System.Posix.Types (Fd(..))--import qualified GHC.Event.Array    as A-import           GHC.Event.Internal (Timeout(..))--available :: Bool-available = True-{-# INLINE available #-}--data EPoll = EPoll {-      epollFd     :: {-# UNPACK #-} !EPollFd-    , epollEvents :: {-# UNPACK #-} !(A.Array Event)-    }---- | Create a new epoll backend.-new :: IO E.Backend-new = do-  epfd <- epollCreate-  evts <- A.new 64-  let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts)-  return be--delete :: EPoll -> IO ()-delete be = do-  _ <- c_close . fromEPollFd . epollFd $ be-  return ()---- | Change the set of events we are interested in for a given file--- descriptor.-modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO Bool-modifyFd ep fd oevt nevt =-  with (Event (fromEvent nevt) fd) $ \evptr -> do-    epollControl (epollFd ep) op fd evptr-    return True-  where op | oevt == mempty = controlOpAdd-           | nevt == mempty = controlOpDelete-           | otherwise      = controlOpModify--modifyFdOnce :: EPoll -> Fd -> E.Event -> IO Bool-modifyFdOnce ep fd evt =-  do let !ev = fromEvent evt .|. epollOneShot-     res <- with (Event ev fd) $-            epollControl_ (epollFd ep) controlOpModify fd-     if res == 0-       then return True-       else do err <- getErrno-               if err == eNOENT-                 then with (Event ev fd) $ \evptr -> do-                        epollControl (epollFd ep) controlOpAdd fd evptr-                        return True-                 else throwErrno "modifyFdOnce"---- | Select a set of file descriptors which are ready for I/O--- operations and call @f@ for all ready file descriptors, passing the--- events that are ready.-poll :: EPoll                     -- ^ state-     -> Maybe Timeout             -- ^ timeout in milliseconds-     -> (Fd -> E.Event -> IO ())  -- ^ I/O callback-     -> IO Int-poll ep mtimeout f = do-  let events = epollEvents ep-      fd = epollFd ep--  -- 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-    Nothing      -> epollWaitNonBlock fd es cap--  when (n > 0) $ do-    A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))-    cap <- A.capacity events-    when (cap == n) $ A.ensureCapacity events (2 * cap)-  return n--newtype EPollFd = EPollFd {-      fromEPollFd :: CInt-    } deriving (Eq, Show)--data Event = Event {-      eventTypes :: EventType-    , eventFd    :: Fd-    } deriving (Show)---- | @since 4.3.1.0-instance Storable Event where-    sizeOf    _ = #size struct epoll_event-    alignment _ = alignment (undefined :: CInt)--    peek ptr = do-        ets <- #{peek struct epoll_event, events} ptr-        ed  <- #{peek struct epoll_event, data.fd}   ptr-        let !ev = Event (EventType ets) ed-        return ev--    poke ptr e = do-        #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e)-        #{poke struct epoll_event, data.fd}   ptr (eventFd e)--newtype ControlOp = ControlOp CInt--#{enum ControlOp, ControlOp- , controlOpAdd    = EPOLL_CTL_ADD- , controlOpModify = EPOLL_CTL_MOD- , controlOpDelete = EPOLL_CTL_DEL- }--newtype EventType = EventType {-      unEventType :: Word32-    } deriving ( Show       -- ^ @since 4.4.0.0-               , Eq         -- ^ @since 4.4.0.0-               , Num        -- ^ @since 4.4.0.0-               , Bits       -- ^ @since 4.4.0.0-               , FiniteBits -- ^ @since 4.7.0.0-               )--#{enum EventType, EventType- , epollIn  = EPOLLIN- , epollOut = EPOLLOUT- , epollErr = EPOLLERR- , epollHup = EPOLLHUP- , epollOneShot = EPOLLONESHOT- }---- | Create a new epoll context, returning a file descriptor associated with the context.--- The fd may be used for subsequent calls to this epoll context.------ The size parameter to epoll_create is a hint about the expected number of handles.------ The file descriptor returned from epoll_create() should be destroyed via--- a call to close() after polling is finished----epollCreate :: IO EPollFd-epollCreate = do-  fd <- throwErrnoIfMinus1 "epollCreate" $-        c_epoll_create 256 -- argument is ignored-  setCloseOnExec fd-  let !epollFd' = EPollFd fd-  return epollFd'--epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()-epollControl epfd op fd event =-    throwErrnoIfMinus1_ "epollControl" $ epollControl_ epfd op fd event--epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt-epollControl_ (EPollFd epfd) (ControlOp op) (Fd fd) event =-    c_epoll_ctl epfd op fd event--epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int-epollWait (EPollFd epfd) events numEvents timeout =-    fmap fromIntegral .-    E.throwErrnoIfMinus1NoRetry "epollWait" $-    c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)--epollWaitNonBlock :: EPollFd -> Ptr Event -> Int -> IO Int-epollWaitNonBlock (EPollFd epfd) events numEvents =-  fmap fromIntegral .-  E.throwErrnoIfMinus1NoRetry "epollWaitNonBlock" $-  c_epoll_wait_unsafe epfd events (fromIntegral numEvents) 0--fromEvent :: E.Event -> EventType-fromEvent e = remap E.evtRead  epollIn .|.-              remap E.evtWrite epollOut-  where remap evt to-            | e `E.eventIs` evt = to-            | otherwise         = 0--toEvent :: EventType -> E.Event-toEvent e = remap (epollIn  .|. epollErr .|. epollHup) E.evtRead `mappend`-            remap (epollOut .|. epollErr .|. epollHup) E.evtWrite-  where remap evt to-            | e .&. evt /= 0 = to-            | otherwise      = mempty--fromTimeout :: Timeout -> Int-fromTimeout Forever     = -1-fromTimeout (Timeout s) = fromIntegral $ s `divRoundUp` 1000000-  where-    divRoundUp num denom = (num + denom - 1) `div` denom--foreign import ccall unsafe "sys/epoll.h epoll_create"-    c_epoll_create :: CInt -> IO CInt--foreign import ccall unsafe "sys/epoll.h epoll_ctl"-    c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt--foreign import ccall safe "sys/epoll.h epoll_wait"-    c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt--foreign import ccall unsafe "sys/epoll.h epoll_wait"-    c_epoll_wait_unsafe :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt-#endif /* defined(HAVE_EPOLL) */-
− GHC/Event/IntTable.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns, NoImplicitPrelude, RecordWildCards #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module GHC.Event.IntTable-    (-      IntTable-    , new-    , lookup-    , insertWith-    , reset-    , delete-    , updateWith-    ) where--import Data.Bits ((.&.), shiftL, shiftR)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.Maybe (Maybe(..), isJust)-import GHC.Base (Monad(..), (=<<), ($), ($!), const, liftM, otherwise, when)-import GHC.Classes (Eq(..), Ord(..))-import GHC.Event.Arr (Arr)-import GHC.Event.IntVar-import GHC.Num (Num(..))-import GHC.Prim (seq)-import GHC.Types (Bool(..), IO(..), Int(..))-import qualified GHC.Event.Arr as Arr---- A very simple chained integer-keyed mutable hash table. We use--- power-of-two sizing, grow at a load factor of 0.75, and never--- shrink. The "hash function" is the identity function.--newtype IntTable a = IntTable (IORef (IT a))--data IT a = IT {-      tabArr  :: {-# UNPACK #-} !(Arr (Bucket a))-    , tabSize :: {-# UNPACK #-} !IntVar-    }--data Bucket a = Empty-              | Bucket {-      bucketKey   :: {-# UNPACK #-} !Int-    , bucketValue :: a-    , bucketNext  :: Bucket a-    }--lookup :: Int -> IntTable a -> IO (Maybe a)-lookup k (IntTable ref) = do-  let go Bucket{..}-        | bucketKey == k = Just bucketValue-        | otherwise      = go bucketNext-      go _ = Nothing-  it@IT{..} <- readIORef ref-  bkt <- Arr.read tabArr (indexOf k it)-  return $! go bkt--new :: Int -> IO (IntTable a)-new capacity = IntTable `liftM` (newIORef =<< new_ capacity)--new_ :: Int -> IO (IT a)-new_ capacity = do-  arr <- Arr.new Empty capacity-  size <- newIntVar 0-  return IT { tabArr = arr-            , tabSize = size-            }--grow :: IT a -> IORef (IT a) -> Int -> IO ()-grow oldit ref size = do-  newit <- new_ (Arr.size (tabArr oldit) `shiftL` 1)-  let copySlot n !i-        | n == size = return ()-        | otherwise = do-          let copyBucket !m Empty          = copySlot m (i+1)-              copyBucket  m bkt@Bucket{..} = do-                let idx = indexOf bucketKey newit-                next <- Arr.read (tabArr newit) idx-                Arr.write (tabArr newit) idx bkt { bucketNext = next }-                copyBucket (m+1) bucketNext-          copyBucket n =<< Arr.read (tabArr oldit) i-  copySlot 0 0-  writeIntVar (tabSize newit) size-  writeIORef ref newit---- | @insertWith f k v table@ inserts @k@ into @table@ with value @v@.--- If @k@ already appears in @table@ with value @v0@, the value is updated--- to @f v0 v@ and @Just v0@ is returned.-insertWith :: (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a)-insertWith f k v inttable@(IntTable ref) = do-  it@IT{..} <- readIORef ref-  let idx = indexOf k it-      go seen bkt@Bucket{..}-        | bucketKey == k = do-          let !v' = f v bucketValue-              !next = seen <> bucketNext-              Empty        <> bs = bs-              b@Bucket{..} <> bs = b { bucketNext = bucketNext <> bs }-          Arr.write tabArr idx (Bucket k v' next)-          return (Just bucketValue)-        | otherwise = go bkt { bucketNext = seen } bucketNext-      go seen _ = do-        size <- readIntVar tabSize-        if size + 1 >= Arr.size tabArr - (Arr.size tabArr `shiftR` 2)-          then grow it ref size >> insertWith f k v inttable-          else do-            v `seq` Arr.write tabArr idx (Bucket k v seen)-            writeIntVar tabSize (size + 1)-            return Nothing-  go Empty =<< Arr.read tabArr idx-{-# INLINABLE insertWith #-}---- | Used to undo the effect of a prior insertWith.-reset :: Int -> Maybe a -> IntTable a -> IO ()-reset k (Just v) tbl = insertWith const k v tbl >> return ()-reset k Nothing  tbl = delete k tbl >> return ()--indexOf :: Int -> IT a -> Int-indexOf k IT{..} = k .&. (Arr.size tabArr - 1)---- | Remove the given key from the table and return its associated value.-delete :: Int -> IntTable a -> IO (Maybe a)-delete k t = updateWith (const Nothing) k t--updateWith :: (a -> Maybe a) -> Int -> IntTable a -> IO (Maybe a)-updateWith f k (IntTable ref) = do-  it@IT{..} <- readIORef ref-  let idx = indexOf k it-      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 = (False, Nothing, e)-  (del, oldVal, newBucket) <- go `liftM` Arr.read tabArr idx-  when (isJust oldVal) $ do-    Arr.write tabArr idx newBucket-    when del $ do-      size <- readIntVar tabSize-      writeIntVar tabSize (size - 1)-  return oldVal-
− GHC/Event/IntVar.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, UnboxedTuples #-}--module GHC.Event.IntVar-    ( IntVar-    , newIntVar-    , readIntVar-    , writeIntVar-    ) where--import GHC.Base-import GHC.Bits--data IntVar = IntVar (MutableByteArray# RealWorld)--newIntVar :: Int -> IO IntVar-newIntVar n = do-  let !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3-  iv <- IO $ \s ->-    case newByteArray# size s of-      (# s', mba #) -> (# s', IntVar mba #)-  writeIntVar iv n-  return iv--readIntVar :: IntVar -> IO Int-readIntVar (IntVar mba) = IO $ \s ->-  case readIntArray# mba 0# s of-    (# s', n #) -> (# s', I# n #)--writeIntVar :: IntVar -> Int -> IO ()-writeIntVar (IntVar mba) (I# n) = IO $ \s ->-  case writeIntArray# mba 0# n s of-    s' -> (# s', () #)
− GHC/Event/Internal.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}--module GHC.Event.Internal-    (-    -- * Event back end-      Backend-    , backend-    , delete-    , poll-    , modifyFd-    , modifyFdOnce-    , module GHC.Event.Internal.Types-    -- * Helpers-    , throwErrnoIfMinus1NoRetry--    -- Atomic ptr exchange for WinIO-    , exchangePtr-    ) where--import Foreign.C.Error (eINTR, getErrno, throwErrno)-import System.Posix.Types (Fd)-import GHC.Base-import GHC.Num (Num(..))-import GHC.Event.Internal.Types--import GHC.Ptr (Ptr(..))---- | Event notification backend.-data Backend = forall a. Backend {-      _beState :: !a--    -- | Poll backend for new events.  The provided callback is called-    -- once per file descriptor with new events.-    , _bePoll :: a                          -- backend state-              -> Maybe Timeout              -- timeout in milliseconds ('Nothing' for non-blocking poll)-              -> (Fd -> Event -> IO ())     -- I/O callback-              -> IO Int--    -- | Register, modify, or unregister interest in the given events-    -- on the given file descriptor.-    , _beModifyFd :: a-                  -> Fd       -- file descriptor-                  -> Event    -- old events to watch for ('mempty' for new)-                  -> Event    -- new events to watch for ('mempty' to delete)-                  -> IO Bool--    -- | Register interest in new events on a given file descriptor, set-    -- to be deactivated after the first event.-    , _beModifyFdOnce :: a-                         -> Fd    -- file descriptor-                         -> Event -- new events to watch-                         -> IO Bool--    , _beDelete :: a -> IO ()-    }--backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)-        -> (a -> Fd -> Event -> Event -> IO Bool)-        -> (a -> Fd -> Event -> IO Bool)-        -> (a -> IO ())-        -> a-        -> Backend-backend bPoll bModifyFd bModifyFdOnce bDelete state =-  Backend state bPoll bModifyFd bModifyFdOnce bDelete-{-# INLINE backend #-}--poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int-poll (Backend bState bPoll _ _ _) = bPoll bState-{-# INLINE poll #-}---- | Returns 'True' if the modification succeeded.--- Returns 'False' if this backend does not support--- event notifications on this type of file.-modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool-modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState-{-# INLINE modifyFd #-}---- | Returns 'True' if the modification succeeded.--- Returns 'False' if this backend does not support--- event notifications on this type of file.-modifyFdOnce :: Backend -> Fd -> Event -> IO Bool-modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState-{-# INLINE modifyFdOnce #-}--delete :: Backend -> IO ()-delete (Backend bState _ _ _ bDelete) = bDelete bState-{-# INLINE delete #-}---- | Throw an 'Prelude.IOError' corresponding to the current value of--- 'getErrno' if the result value of the 'IO' action is -1 and--- 'getErrno' is not 'eINTR'.  If the result value is -1 and--- 'getErrno' returns 'eINTR' 0 is returned.  Otherwise the result--- value is returned.-throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a-throwErrnoIfMinus1NoRetry loc f = do-    res <- f-    if res == -1-        then do-            err <- getErrno-            if err == eINTR then return 0 else throwErrno loc-        else return res--{-# INLINE exchangePtr #-}--- | @exchangePtr pptr x@ swaps the pointer pointed to by @pptr@ with the value--- @x@, returning the old value.-exchangePtr :: Ptr (Ptr a) -> Ptr a -> IO (Ptr a)-exchangePtr (Ptr dst) (Ptr val) =-  IO $ \s ->-      case (atomicExchangeAddrAddr# dst val s) of-        (# s2, old_val #) -> (# s2, Ptr old_val #)
− GHC/Event/Internal/Types.hs 
@@ -1,160 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}----------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Types--- Copyright   :  (c) Tamar Christina 2018--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Abstraction over C Handle types for GHC, Unix wants FD (CInt) while Windows--- Wants Handle (CIntPtr), so we abstract over them here.-------------------------------------------------------------------------------------module GHC.Event.Internal.Types-    (-    -- * Event type-      Event-    , evtRead-    , evtWrite-    , evtClose-    , evtNothing-    , eventIs-    -- * Lifetimes-    , Lifetime(..)-    , EventLifetime-    , eventLifetime-    , elLifetime-    , elEvent-    -- * Timeout type-    , Timeout(..)-    ) where--import Data.OldList (foldl', filter, intercalate, null)--import Data.Bits ((.|.), (.&.))-import Data.Semigroup.Internal (stimesMonoid)--import GHC.Base-import GHC.Show (Show(..))-import GHC.Word (Word64)---- | An I\/O event.-newtype Event = Event Int-    deriving Eq -- ^ @since 4.4.0.0--evtNothing :: Event-evtNothing = Event 0-{-# INLINE evtNothing #-}---- | Data is available to be read.-evtRead :: Event-evtRead = Event 1-{-# INLINE evtRead #-}---- | The file descriptor is ready to accept a write.-evtWrite :: Event-evtWrite = Event 2-{-# INLINE evtWrite #-}---- | Another thread closed the file descriptor.-evtClose :: Event-evtClose = Event 4-{-# INLINE evtClose #-}--eventIs :: Event -> Event -> Bool-eventIs (Event a) (Event b) = a .&. b /= 0---- | @since 4.4.0.0-instance Show Event where-    show e = '[' : (intercalate "," . filter (not . null) $-                    [evtRead `so` "evtRead",-                     evtWrite `so` "evtWrite",-                     evtClose `so` "evtClose"]) ++ "]"-        where ev `so` disp | e `eventIs` ev = disp-                           | otherwise      = ""---- | @since 4.10.0.0-instance Semigroup Event where-    (<>)    = evtCombine-    stimes  = stimesMonoid---- | @since 4.4.0.0-instance Monoid Event where-    mempty  = evtNothing-    mconcat = evtConcat--evtCombine :: Event -> Event -> Event-evtCombine (Event a) (Event b) = Event (a .|. b)-{-# INLINE evtCombine #-}--evtConcat :: [Event] -> Event-evtConcat = foldl' evtCombine evtNothing-{-# INLINE evtConcat #-}---- | The lifetime of an event registration.------ @since 4.8.1.0-data Lifetime = OneShot   -- ^ the registration will be active for only one-                          -- event-              | MultiShot -- ^ the registration will trigger multiple times-              deriving ( Show -- ^ @since 4.8.1.0-                       , Eq   -- ^ @since 4.8.1.0-                       )---- | The longer of two lifetimes.-elSupremum :: Lifetime -> Lifetime -> Lifetime-elSupremum OneShot OneShot = OneShot-elSupremum _       _       = MultiShot-{-# INLINE elSupremum #-}---- | @since 4.10.0.0-instance Semigroup Lifetime where-    (<>) = elSupremum-    stimes = stimesMonoid---- | @mappend@ takes the longer of two lifetimes.------ @since 4.8.0.0-instance Monoid Lifetime where-    mempty = OneShot---- | A pair of an event and lifetime------ Here we encode the event in the bottom three bits and the lifetime--- in the fourth bit.-newtype EventLifetime = EL Int-                      deriving ( Show -- ^ @since 4.8.0.0-                               , Eq   -- ^ @since 4.8.0.0-                               )---- | @since 4.11.0.0-instance Semigroup EventLifetime where-    EL a <> EL b = EL (a .|. b)---- | @since 4.8.0.0-instance Monoid EventLifetime where-    mempty = EL 0--eventLifetime :: Event -> Lifetime -> EventLifetime-eventLifetime (Event e) l = EL (e .|. lifetimeBit l)-  where-    lifetimeBit OneShot   = 0-    lifetimeBit MultiShot = 8-{-# INLINE eventLifetime #-}--elLifetime :: EventLifetime -> Lifetime-elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot-{-# INLINE elLifetime #-}--elEvent :: EventLifetime -> Event-elEvent (EL x) = Event (x .&. 0x7)-{-# INLINE elEvent #-}---- | A type alias for timeouts, specified in nanoseconds.-data Timeout = Timeout {-# UNPACK #-} !Word64-             | Forever-               deriving Show -- ^ @since 4.4.0.0
− GHC/Event/KQueue.hsc 
@@ -1,309 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE CApiFFI                    #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE Trustworthy                #-}--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Unused LANGUAGE pragma" #-}--module GHC.Event.KQueue-    (-      new-    , available-    ) where--import qualified GHC.Event.Internal as E--#include "EventConfig.h"-#if !defined(HAVE_KQUEUE)-import GHC.Base--new :: IO E.Backend-new = errorWithoutStackTrace "KQueue back end not implemented for this platform"--available :: Bool-available = False-{-# INLINE available #-}-#else--import Data.Bits (Bits(..), FiniteBits(..))-import Data.Int-import Data.Maybe ( catMaybes )-import Data.Word (Word16, Word32)-import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,-                        eNOTSUP, getErrno, throwErrno)-import Foreign.C.Types-import Foreign.Marshal.Alloc (alloca)-import Foreign.Marshal.Array (withArrayLen)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (Storable(..))-import GHC.Base-import GHC.Enum (toEnum)-import GHC.Num (Num(..))-import GHC.Real (quotRem, fromIntegral)-import GHC.Show (Show(show))-import GHC.Event.Internal (Timeout(..))-import System.Posix.Internals (c_close)-import System.Posix.Types (Fd(..))-import qualified GHC.Event.Array as A--#if defined(netbsd_HOST_OS)-import Data.Int (Int64)-#endif--#include <sys/types.h>-#include <sys/event.h>-#include <sys/time.h>---- Handle brokenness on some BSD variants, notably OS X up to at least--- 10.6.  If NOTE_EOF isn't available, we have no way to receive a--- notification from the kernel when we reach EOF on a plain file.-#if !defined(NOTE_EOF)-# define NOTE_EOF 0-#endif--available :: Bool-available = True-{-# INLINE available #-}----------------------------------------------------------------------------- Exported interface--data KQueue = KQueue {-      kqueueFd     :: {-# UNPACK #-} !KQueueFd-    , kqueueEvents :: {-# UNPACK #-} !(A.Array Event)-    }--new :: IO E.Backend-new = do-  kqfd <- kqueue-  events <- A.new 64-  let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)-  return be--delete :: KQueue -> IO ()-delete kq = do-  _ <- c_close . fromKQueueFd . kqueueFd $ kq-  return ()--modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool-modifyFd kq fd oevt nevt = do-  kqueueControl (kqueueFd kq) evs-  where-    evs = toEvents fd (toFilter oevt) flagDelete noteEOF-       <> toEvents fd (toFilter nevt) flagAdd noteEOF--toFilter :: E.Event -> [Filter]-toFilter e = catMaybes [ check E.evtRead filterRead, check E.evtWrite filterWrite ]-  where-    check e' f = if e `E.eventIs` e' then Just f else Nothing--modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool-modifyFdOnce kq fd evt =-    kqueueControl (kqueueFd kq) (toEvents fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF)--poll :: KQueue-     -> Maybe Timeout-     -> (Fd -> E.Event -> IO ())-     -> IO Int-poll kq mtimeout f = do-    let events = kqueueEvents kq-        fd = kqueueFd kq--    n <- A.unsafeLoad events $ \es cap -> case mtimeout of-      Just timeout -> kqueueWait fd es cap $ fromTimeout timeout-      Nothing      -> kqueueWaitNonBlock fd es cap--    when (n > 0) $ do-        A.forM_ events $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))-        cap <- A.capacity events-        when (n == cap) $ A.ensureCapacity events (2 * cap)-    return n---------------------------------------------------------------------------- FFI binding--newtype KQueueFd = KQueueFd {-      fromKQueueFd :: CInt-    } deriving ( Eq   -- ^ @since 4.4.0.0-               , Show -- ^ @since 4.4.0.0-               )--data Event = KEvent {-      ident  :: {-# UNPACK #-} !CUIntPtr-    , filter :: {-# UNPACK #-} !Filter-    , flags  :: {-# UNPACK #-} !Flag-    , fflags :: {-# UNPACK #-} !FFlag-#if defined(netbsd_HOST_OS)-    , data_  :: {-# UNPACK #-} !Int64-#else-    , data_  :: {-# UNPACK #-} !CIntPtr-#endif-    , udata  :: {-# UNPACK #-} !(Ptr ())-    } deriving Show -- ^ @since 4.4.0.0--toEvents :: Fd -> [Filter] -> Flag -> FFlag -> [Event]-toEvents fd flts flag fflag = map (\filt -> KEvent (fromIntegral fd) filt flag fflag 0 nullPtr) flts---- | @since 4.3.1.0-instance Storable Event where-    sizeOf _ = #size struct kevent-    alignment _ = alignment (undefined :: CInt)--    peek ptr = do-        ident'  <- #{peek struct kevent, ident} ptr-        filter' <- #{peek struct kevent, filter} ptr-        flags'  <- #{peek struct kevent, flags} ptr-        fflags' <- #{peek struct kevent, fflags} ptr-        data'   <- #{peek struct kevent, data} ptr-        udata'  <- #{peek struct kevent, udata} ptr-        let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'-                         udata'-        return ev--    poke ptr ev = do-        #{poke struct kevent, ident} ptr (ident ev)-        #{poke struct kevent, filter} ptr (filter ev)-        #{poke struct kevent, flags} ptr (flags ev)-        #{poke struct kevent, fflags} ptr (fflags ev)-        #{poke struct kevent, data} ptr (data_ ev)-        #{poke struct kevent, udata} ptr (udata ev)--newtype FFlag = FFlag Word32-    deriving ( Eq       -- ^ @since 4.4.0.0-             , Show     -- ^ @since 4.4.0.0-             , Storable -- ^ @since 4.4.0.0-             )--#{enum FFlag, FFlag- , noteEOF = NOTE_EOF- }--#if SIZEOF_KEV_FLAGS == 4 /* kevent.flag: uint32_t or uint16_t. */-newtype Flag = Flag Word32-#else-newtype Flag = Flag Word16-#endif-    deriving ( Bits       -- ^ @since 4.7.0.0-             , FiniteBits -- ^ @since 4.7.0.0-             , Eq         -- ^ @since 4.4.0.0-             , Num        -- ^ @since 4.7.0.0-             , Show       -- ^ @since 4.4.0.0-             , Storable   -- ^ @since 4.4.0.0-             )--#{enum Flag, Flag- , flagAdd     = EV_ADD- , flagDelete  = EV_DELETE- , flagOneshot = EV_ONESHOT- }--#if SIZEOF_KEV_FILTER == 4 /*kevent.filter: int32_t or int16_t. */-newtype Filter = Filter Int32-#else-newtype Filter = Filter Int16-#endif-    deriving ( Eq       -- ^ @since 4.4.0.0-             , Num      -- ^ @since 4.4.0.0-             , Show     -- ^ @since 4.4.0.0-             , Storable -- ^ @since 4.4.0.0-             )--filterRead :: Filter-filterRead = Filter (#const EVFILT_READ)-filterWrite :: Filter-filterWrite  = Filter (#const EVFILT_WRITE)--data TimeSpec = TimeSpec {-      tv_sec  :: {-# UNPACK #-} !CTime-    , tv_nsec :: {-# UNPACK #-} !CLong-    }---- | @since 4.3.1.0-instance Storable TimeSpec where-    sizeOf _ = #size struct timespec-    alignment _ = alignment (undefined :: CInt)--    peek ptr = do-        tv_sec'  <- #{peek struct timespec, tv_sec} ptr-        tv_nsec' <- #{peek struct timespec, tv_nsec} ptr-        let !ts = TimeSpec tv_sec' tv_nsec'-        return ts--    poke ptr ts = do-        #{poke struct timespec, tv_sec} ptr (tv_sec ts)-        #{poke struct timespec, tv_nsec} ptr (tv_nsec ts)--kqueue :: IO KQueueFd-kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue--kqueueControl :: KQueueFd -> [Event] -> IO Bool-kqueueControl kfd evts =-    withTimeSpec (TimeSpec 0 0) $ \tp ->-        withArrayLen evts $ \evlen evp -> do-            res <- kevent False kfd evp evlen nullPtr 0 tp-            if res == -1-              then do-               err <- getErrno-               case err of-                 _ | err == eINTR  -> return True-                 _ | err == eINVAL -> return False-                 _ | err == eNOTSUP -> return False-                 _                 -> throwErrno "kevent"-              else return True--kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int-kqueueWait fd es cap tm =-    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $-    withTimeSpec tm $ kevent True fd nullPtr 0 es cap--kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int-kqueueWaitNonBlock fd es cap =-    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $-    withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap---- TODO: We cannot retry on EINTR as the timeout would be wrong.--- Perhaps we should just return without calling any callbacks.-kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec-       -> IO CInt-kevent safe k chs chlen evs evlen ts-  | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts-  | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts--withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a-withTimeSpec ts f-  | tv_sec ts < 0 = f nullPtr-  | otherwise     = alloca $ \ptr -> poke ptr ts >> f ptr--fromTimeout :: Timeout -> TimeSpec-fromTimeout Forever     = TimeSpec (-1) (-1)-fromTimeout (Timeout s) = TimeSpec (toEnum sec') (toEnum nanosec')-  where-    (sec, nanosec) = s `quotRem` 1000000000--    nanosec', sec' :: Int-    sec' = fromIntegral sec-    nanosec' = fromIntegral nanosec--toEvent :: Filter -> E.Event-toEvent (Filter f)-  | f == (#const EVFILT_READ) = E.evtRead-  | f == (#const EVFILT_WRITE) = E.evtWrite-  | otherwise = errorWithoutStackTrace $ "toEvent: unknown filter " ++ show f--foreign import ccall unsafe "kqueue"-    c_kqueue :: IO CInt--#if defined(HAVE_KEVENT)-foreign import capi safe "sys/event.h kevent"-    c_kevent :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt-             -> Ptr TimeSpec -> IO CInt--foreign import ccall unsafe "kevent"-    c_kevent_unsafe :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt-                    -> Ptr TimeSpec -> IO CInt-#else-#error no kevent system call available!?-#endif--#endif /* defined(HAVE_KQUEUE) */
− GHC/Event/Manager.hs 
@@ -1,523 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Trustworthy #-}---- |--- The event manager supports event notification on fds. Each fd may--- have multiple callbacks registered, each listening for a different--- set of events. Registrations may be automatically deactivated after--- the occurrence of an event ("one-shot mode") or active until--- explicitly unregistered.------ If an fd has only one-shot registrations then we use one-shot--- polling if available. Otherwise we use multi-shot polling.--module GHC.Event.Manager-    ( -- * Types-      EventManager--      -- * Creation-    , new-    , newWith-    , newDefaultBackend--      -- * Running-    , finished-    , loop-    , step-    , shutdown-    , release-    , cleanup-    , wakeManager--      -- * State-    , callbackTableVar-    , emControl--      -- * Registering interest in I/O events-    , Lifetime (..)-    , Event-    , evtRead-    , evtWrite-    , IOCallback-    , FdKey(keyFd)-    , FdData-    , registerFd-    , unregisterFd_-    , unregisterFd-    , closeFd-    , closeFd_-    ) where--#include "EventConfig.h"----------------------------------------------------------------------------- Imports--import Control.Concurrent.MVar (MVar, newMVar, putMVar,-                                tryPutMVar, takeMVar, withMVar)-import Control.Exception (onException)-import Data.Bits ((.&.))-import Data.Foldable (forM_)-import Data.Functor (void)-import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,-                   writeIORef)-import Data.Maybe (maybe)-import Data.OldList (partition)-import GHC.Arr (Array, (!), listArray)-import GHC.Base-import GHC.Conc.Sync (yield)-import GHC.List (filter, replicate)-import GHC.Num (Num(..))-import GHC.Real (fromIntegral)-import GHC.Show (Show(..))-import GHC.Event.Control-import GHC.Event.IntTable (IntTable)-import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,-                           Lifetime(..), EventLifetime, Timeout(..))-import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)-import System.Posix.Types (Fd)--import qualified GHC.Event.IntTable as IT-import qualified GHC.Event.Internal as I--#if defined(HAVE_KQUEUE)-import qualified GHC.Event.KQueue as KQueue-#elif defined(HAVE_EPOLL)-import qualified GHC.Event.EPoll  as EPoll-#elif defined(HAVE_POLL)-import qualified GHC.Event.Poll   as Poll-#else-# error not implemented for this operating system-#endif----------------------------------------------------------------------------- Types--data FdData = FdData {-      fdKey       :: {-# UNPACK #-} !FdKey-    , fdEvents    :: {-# UNPACK #-} !EventLifetime-    , _fdCallback :: !IOCallback-    }---- | A file descriptor registration cookie.-data FdKey = FdKey {-      keyFd     :: {-# UNPACK #-} !Fd-    , keyUnique :: {-# UNPACK #-} !Unique-    } deriving ( Eq   -- ^ @since 4.4.0.0-               , Show -- ^ @since 4.4.0.0-               )---- | Callback invoked on I/O events.-type IOCallback = FdKey -> Event -> IO ()--data State = Created-           | Running-           | Dying-           | Releasing-           | Finished-             deriving ( Eq   -- ^ @since 4.4.0.0-                      , Show -- ^ @since 4.4.0.0-                      )---- | The event manager state.-data EventManager = EventManager-    { emBackend      :: !Backend-    , emFds          :: {-# UNPACK #-} !(Array Int (MVar (IntTable [FdData])))-    , emState        :: {-# UNPACK #-} !(IORef State)-    , emUniqueSource :: {-# UNPACK #-} !UniqueSource-    , emControl      :: {-# UNPACK #-} !Control-    , emLock         :: {-# UNPACK #-} !(MVar ())-    }---- must be power of 2-callbackArraySize :: Int-callbackArraySize = 32--hashFd :: Fd -> Int-hashFd fd = fromIntegral fd .&. (callbackArraySize - 1)-{-# INLINE hashFd #-}--callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData])-callbackTableVar mgr fd = emFds mgr ! hashFd fd-{-# INLINE callbackTableVar #-}--haveOneShot :: Bool-{-# INLINE haveOneShot #-}-#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)-haveOneShot = False-#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)-haveOneShot = True-#else-haveOneShot = False-#endif---------------------------------------------------------------------------- Creation--handleControlEvent :: EventManager -> Fd -> Event -> IO ()-handleControlEvent mgr fd _evt = do-  msg <- readControlMessage (emControl mgr) fd-  case msg of-    CMsgWakeup      -> return ()-    CMsgDie         -> writeIORef (emState mgr) Finished-    _               -> return ()--newDefaultBackend :: IO Backend-#if defined(HAVE_KQUEUE)-newDefaultBackend = KQueue.new-#elif defined(HAVE_EPOLL)-newDefaultBackend = EPoll.new-#elif defined(HAVE_POLL)-newDefaultBackend = Poll.new-#else-newDefaultBackend = errorWithoutStackTrace "no back end for this platform"-#endif---- | Create a new event manager.-new :: IO EventManager-new = newWith =<< newDefaultBackend---- | Create a new 'EventManager' with the given polling backend.-newWith :: Backend -> IO EventManager-newWith be = do-  iofds <- fmap (listArray (0, callbackArraySize-1)) $-           replicateM callbackArraySize (newMVar =<< IT.new 8)-  ctrl <- newControl False-  state <- newIORef Created-  us <- newSource-  _ <- mkWeakIORef state $ do-               st <- atomicModifyIORef' state $ \s -> (Finished, s)-               when (st /= Finished) $ do-                 I.delete be-                 closeControl ctrl-  lockVar <- newMVar ()-  let mgr = EventManager { emBackend = be-                         , emFds = iofds-                         , emState = state-                         , emUniqueSource = us-                         , emControl = ctrl-                         , emLock = lockVar-                         }-  registerControlFd mgr (controlReadFd ctrl) evtRead-  registerControlFd mgr (wakeupReadFd ctrl) evtRead-  return mgr-  where-    replicateM n x = sequence (replicate n x)--failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()-failOnInvalidFile loc fd m = do-  ok <- m-  when (not ok) $-    let msg = "Failed while attempting to modify registration of file " ++-              show fd ++ " at location " ++ loc-    in errorWithoutStackTrace msg--registerControlFd :: EventManager -> Fd -> Event -> IO ()-registerControlFd mgr fd evs =-  failOnInvalidFile "registerControlFd" fd $-  I.modifyFd (emBackend mgr) fd mempty evs---- | Asynchronously shuts down the event manager, if running.-shutdown :: EventManager -> IO ()-shutdown mgr = do-  state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)-  when (state == Running) $ sendDie (emControl mgr)---- | Asynchronously tell the thread executing the event--- manager loop to exit.-release :: EventManager -> IO ()-release EventManager{..} = do-  state <- atomicModifyIORef' emState $ \s -> (Releasing, s)-  when (state == Running) $ sendWakeup emControl--finished :: EventManager -> IO Bool-finished mgr = (== Finished) `liftM` readIORef (emState mgr)--cleanup :: EventManager -> IO ()-cleanup EventManager{..} = do-  writeIORef emState Finished-  void $ tryPutMVar emLock ()-  I.delete emBackend-  closeControl emControl----------------------------------------------------------------------------- Event loop---- | Start handling events.  This function loops until told to stop,--- using 'shutdown'.------ /Note/: This loop can only be run once per 'EventManager', as it--- closes all of its control resources when it finishes.-loop :: EventManager -> IO ()-loop mgr@EventManager{..} = do-  void $ takeMVar emLock-  state <- atomicModifyIORef' emState $ \s -> case s of-    Created -> (Running, s)-    Releasing -> (Running, s)-    _       -> (s, s)-  case state of-    Created   -> go `onException` cleanup mgr-    Releasing -> go `onException` cleanup mgr-    Dying     -> cleanup mgr-    -- While a poll loop is never forked when the event manager is in the-    -- 'Finished' state, its state could read 'Finished' once the new thread-    -- actually runs.  This is not an error, just an unfortunate race condition-    -- in Thread.restartPollLoop.  See #8235-    Finished  -> return ()-    _         -> do cleanup mgr-                    errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++-                            show state- where-  go = do state <- step mgr-          case state of-            Running   -> yield >> go-            Releasing -> putMVar emLock ()-            _         -> cleanup mgr---- | To make a step, we first do a non-blocking poll, in case--- there are already events ready to handle. This improves performance--- because we can make an unsafe foreign C call, thereby avoiding--- forcing the current Task to release the Capability and forcing a context switch.--- If the poll fails to find events, we yield, putting the poll loop thread at--- end of the Haskell run queue. When it comes back around, we do one more--- non-blocking poll, in case we get lucky and have ready events.--- If that also returns no events, then we do a blocking poll.-step :: EventManager -> IO State-step mgr@EventManager{..} = do-  waitForIO-  state <- readIORef emState-  state `seq` return state-  where-    waitForIO = do-      n1 <- I.poll emBackend Nothing (onFdEvent mgr)-      when (n1 <= 0) $ do-        yield-        n2 <- I.poll emBackend Nothing (onFdEvent mgr)-        when (n2 <= 0) $ do-          _ <- I.poll emBackend (Just Forever) (onFdEvent mgr)-          return ()----------------------------------------------------------------------------- Registering interest in I/O events---- | 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-  u <- newUnique emUniqueSource-  let fd'  = fromIntegral fd-      reg  = FdKey fd u-      el = I.eventLifetime evs lt-      !fdd = FdData reg el cb-  (modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl -> do-    oldFdd <- IT.insertWith (++) fd' [fdd] tbl-    let prevEvs :: EventLifetime-        prevEvs = maybe mempty eventsOf oldFdd--        el' :: EventLifetime-        el' = prevEvs `mappend` el-    case I.elLifetime el' of-      -- All registrations want one-shot semantics and this is supported-      OneShot | haveOneShot -> do-        ok <- I.modifyFdOnce emBackend fd (I.elEvent el')-        if ok-          then return (False, True)-          else IT.reset fd' oldFdd tbl >> return (False, False)--      -- We don't want or don't support one-shot semantics-      _ -> do-        let modify = prevEvs /= el'-        ok <- if modify-              then let newEvs = I.elEvent el'-                       oldEvs = I.elEvent prevEvs-                   in I.modifyFd emBackend fd oldEvs newEvs-              else return True-        if ok-          then return (modify, True)-          else IT.reset fd' oldFdd tbl >> return (False, False)-  -- this simulates behavior of old IO manager:-  -- i.e. just call the callback if the registration fails.-  when (not ok) (cb reg evs)-  return (reg,modify)-{-# INLINE registerFd_ #-}---- | @registerFd mgr cb fd evs lt@ registers interest in the events @evs@--- on the file descriptor @fd@ for lifetime @lt@. @cb@ is called for--- each event that occurs.  Returns a cookie that can be handed to--- 'unregisterFd'.-registerFd :: EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey-registerFd mgr cb fd evs lt = do-  (r, wake) <- registerFd_ mgr cb fd evs lt-  when wake $ wakeManager mgr-  return r-{-# INLINE registerFd #-}--{--    Building GHC with parallel IO manager on Mac freezes when-    compiling the dph libraries in the phase 2. As workaround, we-    don't use oneshot and we wake up an IO manager on Mac every time-    when we register an event.--    For more information, please read:-        https://gitlab.haskell.org/ghc/ghc/issues/7651--}--- | Wake up the event manager.-wakeManager :: EventManager -> IO ()-#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)-wakeManager mgr = sendWakeup (emControl mgr)-#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)-wakeManager _ = return ()-#else-wakeManager mgr = sendWakeup (emControl mgr)-#endif--eventsOf :: [FdData] -> EventLifetime-eventsOf [fdd] = fdEvents fdd-eventsOf fdds  = mconcat $ map fdEvents fdds---- | Drop a previous file descriptor registration, without waking the--- event manager thread.  The return value indicates whether the event--- manager ought to be woken.-unregisterFd_ :: EventManager -> FdKey -> IO Bool-unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) =-  withMVar (callbackTableVar mgr fd) $ \tbl -> do-    let dropReg = nullToNothing . filter ((/= u) . keyUnique . fdKey)-        fd' = fromIntegral fd-        pairEvents :: [FdData] -> IO (EventLifetime, EventLifetime)-        pairEvents prev = do-          r <- maybe mempty eventsOf `fmap` IT.lookup fd' tbl-          return (eventsOf prev, r)-    (oldEls, newEls) <- IT.updateWith dropReg fd' tbl >>=-                        maybe (return (mempty, mempty)) pairEvents-    let modify = oldEls /= newEls-    when modify $ failOnInvalidFile "unregisterFd_" fd $-      case I.elLifetime newEls of-        OneShot | I.elEvent newEls /= mempty, haveOneShot ->-          I.modifyFdOnce emBackend fd (I.elEvent newEls)-        _ ->-          I.modifyFd emBackend fd (I.elEvent oldEls) (I.elEvent newEls)-    return modify---- | Drop a previous file descriptor registration.-unregisterFd :: EventManager -> FdKey -> IO ()-unregisterFd mgr reg = do-  wake <- unregisterFd_ mgr reg-  when wake $ wakeManager mgr---- | Close a file descriptor in a race-safe way.  It might block, although for--- a very short time; and thus it is interruptible by asynchronous exceptions.-closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()-closeFd mgr close fd = do-  fds <- withMVar (callbackTableVar mgr fd) $ \tbl -> do-    prev <- IT.delete (fromIntegral fd) tbl-    case prev of-      Nothing  -> close fd >> return []-      Just fds -> do-        let oldEls = eventsOf fds-        when (I.elEvent oldEls /= mempty) $ do-          _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty-          wakeManager mgr-        close fd-        return fds-  forM_ fds $ \(FdData reg el cb) -> cb reg (I.elEvent el `mappend` evtClose)---- | Close a file descriptor in a race-safe way.--- It assumes the caller will update the callback tables and that the caller--- holds the callback table lock for the fd. It must hold this lock because--- this command executes a backend command on the fd.-closeFd_ :: EventManager-         -> IntTable [FdData]-         -> Fd-         -> IO (IO ())-closeFd_ mgr tbl fd = do-  prev <- IT.delete (fromIntegral fd) tbl-  case prev of-    Nothing  -> return (return ())-    Just fds -> do-      let oldEls = eventsOf fds-      when (oldEls /= mempty) $ do-        _ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty-        wakeManager mgr-      return $-        forM_ fds $ \(FdData reg el cb) ->-          cb reg (I.elEvent el `mappend` evtClose)----------------------------------------------------------------------------- Utilities---- | Call the callbacks corresponding to the given file descriptor.-onFdEvent :: EventManager -> Fd -> Event -> IO ()-onFdEvent mgr fd evs-  | fd == controlReadFd (emControl mgr) || fd == wakeupReadFd (emControl mgr) =-    handleControlEvent mgr fd evs--  | otherwise = do-    fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->-        IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl)-    forM_ fdds $ \(FdData reg _ cb) -> cb reg evs-  where-    -- | Here we look through the list of registrations for the fd of interest-    -- and sort out which match the events that were triggered. We,-    ---    --   1. re-arm the fd as appropriate-    --   2. reinsert registrations that weren't triggered and multishot-    --      registrations-    --   3. return a list containing the callbacks that should be invoked.-    selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]-    selectCallbacks tbl fdds = do-        let -- figure out which registrations have been triggered-            matches :: FdData -> Bool-            matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd')-            (triggered, notTriggered) = partition matches fdds--            -- sort out which registrations we need to retain-            isMultishot :: FdData -> Bool-            isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot-            saved = notTriggered ++ filter isMultishot triggered--            savedEls = eventsOf saved-            allEls = eventsOf fdds--        -- Reinsert multishot registrations.-        -- We deleted the table entry for this fd above so we there isn't a preexisting entry-        _ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl--        case I.elLifetime allEls of-          -- we previously armed the fd for multiple shots, no need to rearm-          MultiShot | allEls == savedEls ->-            return ()--          -- either we previously registered for one shot or the-          -- events of interest have changed, we must re-arm-          _ ->-            case I.elLifetime savedEls of-              OneShot | haveOneShot ->-                -- if there are no saved events and we registered with one-shot-                -- semantics then there is no need to re-arm-                unless (OneShot == I.elLifetime allEls-                  && mempty == I.elEvent savedEls) $-                    void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls)-              _ ->-                -- we need to re-arm with multi-shot semantics-                void $ I.modifyFd (emBackend mgr) fd-                                  (I.elEvent allEls) (I.elEvent savedEls)--        return triggered--nullToNothing :: [a] -> Maybe [a]-nullToNothing []       = Nothing-nullToNothing xs@(_:_) = Just xs--unless :: Monad m => Bool -> m () -> m ()-unless p = when (not p)
− GHC/Event/PSQ.hs 
@@ -1,434 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE MagicHash         #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy       #-}-{-# LANGUAGE UnboxedTuples     #-}--module GHC.Event.PSQ-    (-    -- * Binding Type-      Elem(..)-    , Key-    , Prio--    -- * Priority Search Queue Type-    , PSQ--    -- * Query-    , size-    , null-    , lookup--    -- * Construction-    , empty-    , singleton--    -- * Insertion-    , unsafeInsertNew--    -- * Delete/Update-    , delete-    , adjust--    -- * Conversion-    , toList--    -- * Min-    , findMin-    , deleteMin-    , minView-    , atMost-    ) where--import GHC.Base hiding (empty)-import GHC.Event.Unique-import GHC.Word (Word64)-import GHC.Num (Num(..))-import GHC.Real (fromIntegral)--#include "MachDeps.h"---- TODO (SM): get rid of bang patterns--{---- Use macros to define strictness of functions.--- STRICT_x_OF_y denotes a y-ary function strict in the x-th parameter.--- We do not use BangPatterns, because they are not in any standard and we--- want the compilers to be compiled by as many compilers as possible.-#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined--}------------------------------------------------------------------------------------ Types---------------------------------------------------------------------------------type Prio = Word64--type Nat = Word--type Key = Unique---- | We store masks as the index of the bit that determines the branching.-type Mask = Int--type PSQ a = IntPSQ a---- | @E k p@ binds the key @k@ with the priority @p@.-data Elem a = E-    { key   :: {-# UNPACK #-} !Key-    , prio  :: {-# UNPACK #-} !Prio-    , value :: a-    }---- | A priority search queue with @Int@ keys and priorities of type @p@ and--- values of type @v@. It is strict in keys, priorities and values.-data IntPSQ v-    = Bin {-# UNPACK #-} !Key {-# UNPACK #-} !Prio !v {-# UNPACK #-} !Mask !(IntPSQ v) !(IntPSQ v)-    | Tip {-# UNPACK #-} !Key {-# UNPACK #-} !Prio !v-    | Nil---- bit twiddling-------------------(.&.) :: Nat -> Nat -> Nat-(.&.) (W# w1) (W# w2) = W# (w1 `and#` w2)-{-# INLINE (.&.) #-}--xor :: Nat -> Nat -> Nat-xor (W# w1) (W# w2) = W# (w1 `xor#` w2)-{-# INLINE xor #-}--complement :: Nat -> Nat-complement (W# w) = W# (w `xor#` mb)-  where-#if WORD_SIZE_IN_BITS == 32-    mb = 0xFFFFFFFF##-#elif WORD_SIZE_IN_BITS == 64-    mb = 0xFFFFFFFFFFFFFFFF##-#else-#error Unhandled value for WORD_SIZE_IN_BITS-#endif-{-# INLINE complement #-}--{-# INLINE natFromInt #-}-natFromInt :: Int -> Nat-natFromInt = fromIntegral--{-# INLINE intFromNat #-}-intFromNat :: Nat -> Int-intFromNat = fromIntegral--{-# INLINE zero #-}-zero :: Key -> Mask -> Bool-zero i m-  = (natFromInt (asInt i)) .&. (natFromInt m) == 0--{-# INLINE nomatch #-}-nomatch :: Key -> Key -> Mask -> Bool-nomatch k1 k2 m =-    natFromInt (asInt k1) .&. m' /= natFromInt (asInt k2) .&. m'-  where-    m' = maskW (natFromInt m)--{-# INLINE maskW #-}-maskW :: Nat -> Nat-maskW m = complement (m-1) `xor` m--{-# INLINE branchMask #-}-branchMask :: Key -> Key -> Mask-branchMask k1' k2' =-    intFromNat (highestBitMask (natFromInt k1 `xor` natFromInt k2))-  where-    k1 = asInt k1'-    k2 = asInt k2'--highestBitMask :: Nat -> Nat-highestBitMask (W# x) =-    W# (uncheckedShiftL# 1## (word2Int# (WORD_SIZE_IN_BITS## `minusWord#` 1## `minusWord#` clz# x)))-{-# INLINE highestBitMask #-}----------------------------------------------------------------------------------- Query----------------------------------------------------------------------------------- | /O(1)/ True if the queue is empty.-null :: IntPSQ v -> Bool-null Nil = True-null _   = False---- | /O(n)/ The number of elements stored in the queue.-size :: IntPSQ v -> Int-size Nil               = 0-size (Tip _ _ _)       = 1-size (Bin _ _ _ _ l r) = 1 + size l + size r--- TODO (SM): benchmark this against a tail-recursive variant---- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the--- key is not bound.-lookup :: Key -> IntPSQ v -> Maybe (Prio, v)-lookup k = go-  where-    go t = case t of-        Nil                -> Nothing--        Tip k' p' x'-          | k == k'        -> Just (p', x')-          | otherwise      -> Nothing--        Bin k' p' x' m l r-          | nomatch k k' m -> Nothing-          | k == k'        -> Just (p', x')-          | zero k m       -> go l-          | otherwise      -> go r---- | /O(1)/ The element with the lowest priority.-findMin :: IntPSQ v -> Maybe (Elem v)-findMin t = case t of-    Nil             -> Nothing-    Tip k p x       -> Just (E k p x)-    Bin k p x _ _ _ -> Just (E k p x)------------------------------------------------------------------------------------- Construction----------------------------------------------------------------------------------- | /O(1)/ The empty queue.-empty :: IntPSQ v-empty = Nil---- | /O(1)/ Build a queue with one element.-singleton :: Key -> Prio -> v -> IntPSQ v-singleton = Tip------------------------------------------------------------------------------------ Insertion----------------------------------------------------------------------------------- | /O(min(n,W))/ Insert a new key that is *not* present in the priority queue.-{-# INLINABLE unsafeInsertNew #-}-unsafeInsertNew :: Key -> Prio -> v -> IntPSQ v -> IntPSQ v-unsafeInsertNew k p x = go-  where-    go t = case t of-      Nil       -> Tip k p x--      Tip k' p' x'-        | (p, k) < (p', k') -> link k  p  x  k' t           Nil-        | otherwise         -> link k' p' x' k  (Tip k p x) Nil--      Bin k' p' x' m l r-        | nomatch k k' m ->-            if (p, k) < (p', k')-              then link k  p  x  k' t           Nil-              else link k' p' x' k  (Tip k p x) (merge m l r)--        | otherwise ->-            if (p, k) < (p', k')-              then-                if zero k' m-                  then Bin k  p  x  m (unsafeInsertNew k' p' x' l) r-                  else Bin k  p  x  m l (unsafeInsertNew k' p' x' r)-              else-                if zero k m-                  then Bin k' p' x' m (unsafeInsertNew k  p  x  l) r-                  else Bin k' p' x' m l (unsafeInsertNew k  p  x  r)---- | Link-link :: Key -> Prio -> v -> Key -> IntPSQ v -> IntPSQ v -> IntPSQ v-link k p x k' k't otherTree-  | zero (Unique m) (asInt k') = Bin k p x m k't otherTree-  | otherwise                  = Bin k p x m otherTree k't-  where-    m = branchMask k k'------------------------------------------------------------------------------------ Delete/Alter----------------------------------------------------------------------------------- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When--- the key is not a member of the queue, the original queue is returned.-{-# INLINABLE delete #-}-delete :: Key -> IntPSQ v -> IntPSQ v-delete k = go-  where-    go t = case t of-        Nil           -> Nil--        Tip k' _ _-          | k == k'   -> Nil-          | otherwise -> t--        Bin k' p' x' m l r-          | nomatch k k' m -> t-          | k == k'        -> merge m l r-          | zero k m       -> binShrinkL k' p' x' m (go l) r-          | otherwise      -> binShrinkR k' p' x' m l      (go r)---- | /O(min(n,W))/ Delete the binding with the least priority, and return the--- rest of the queue stripped of that binding. In case the queue is empty, the--- empty queue is returned again.-{-# INLINE deleteMin #-}-deleteMin :: IntPSQ v -> IntPSQ v-deleteMin t = case minView t of-    Nothing      -> t-    Just (_, t') -> t'---adjust-    :: (Prio -> Prio)-    -> Key-    -> PSQ a-    -> PSQ a-adjust f k q = case alter g k q of (_, q') -> q'-  where g (Just (p, v)) = ((), Just ((f p), v))-        g Nothing       = ((), Nothing)--{-# INLINE adjust #-}---- | /O(min(n,W))/ The expression @alter f k queue@ alters the value @x@ at @k@,--- or absence thereof. 'alter' can be used to insert, delete, or update a value--- in a queue. It also allows you to calculate an additional value @b@.-{-# INLINE alter #-}-alter-    :: (Maybe (Prio, v) -> (b, Maybe (Prio, v)))-    -> Key-    -> IntPSQ v-    -> (b, IntPSQ v)-alter f = \k t0 ->-    let (t, mbX) = case deleteView k t0 of-                            Nothing          -> (t0, Nothing)-                            Just (p, v, t0') -> (t0', Just (p, v))-    in case f mbX of-          (b, mbX') ->-            (b, maybe t (\(p, v) -> unsafeInsertNew k p v t) mbX')-    where-        maybe _ g (Just x)  = g x-        maybe def _ Nothing = def---- | Smart constructor for a 'Bin' node whose left subtree could have become--- 'Nil'.-{-# INLINE binShrinkL #-}-binShrinkL :: Key -> Prio -> v -> Mask -> IntPSQ v -> IntPSQ v -> IntPSQ v-binShrinkL k p x m Nil r = case r of Nil -> Tip k p x; _ -> Bin k p x m Nil r-binShrinkL k p x m l   r = Bin k p x m l r---- | Smart constructor for a 'Bin' node whose right subtree could have become--- 'Nil'.-{-# INLINE binShrinkR #-}-binShrinkR :: Key -> Prio -> v -> Mask -> IntPSQ v -> IntPSQ v -> IntPSQ v-binShrinkR k p x m l Nil = case l of Nil -> Tip k p x; _ -> Bin k p x m l Nil-binShrinkR k p x m l r   = Bin k p x m l r----------------------------------------------------------------------------------- Lists----------------------------------------------------------------------------------- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The--- order of the list is not specified.-toList :: IntPSQ v -> [Elem v]-toList =-    go []-  where-    go acc Nil                   = acc-    go acc (Tip k' p' x')        = (E k' p' x') : acc-    go acc (Bin k' p' x' _m l r) = (E k' p' x') : go (go acc r) l------------------------------------------------------------------------------------ Views----------------------------------------------------------------------------------- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If--- the key was present, the associated priority and value are returned in--- addition to the updated queue.-{-# INLINABLE deleteView #-}-deleteView :: Key -> IntPSQ v -> Maybe (Prio, v, IntPSQ v)-deleteView k t0 =-    case delFrom t0 of-      (# _, Nothing     #) -> Nothing-      (# t, Just (p, x) #) -> Just (p, x, t)-  where-    delFrom t = case t of-      Nil -> (# Nil, Nothing #)--      Tip k' p' x'-        | k == k'   -> (# Nil, Just (p', x') #)-        | otherwise -> (# t,   Nothing       #)--      Bin k' p' x' m l r-        | nomatch k k' m -> (# t, Nothing #)-        | k == k'   -> let t' = merge m l r-                       in  t' `seq` (# t', Just (p', x') #)--        | zero k m  -> case delFrom l of-                         (# l', mbPX #) -> let t' = binShrinkL k' p' x' m l' r-                                           in  t' `seq` (# t', mbPX #)--        | otherwise -> case delFrom r of-                         (# r', mbPX #) -> let t' = binShrinkR k' p' x' m l  r'-                                           in  t' `seq` (# t', mbPX #)---- | /O(min(n,W))/ Retrieve the binding with the least priority, and the--- rest of the queue stripped of that binding.-{-# INLINE minView #-}-minView :: IntPSQ v -> Maybe (Elem v, IntPSQ v)-minView t = case t of-    Nil             -> Nothing-    Tip k p x       -> Just (E k p x, Nil)-    Bin k p x m l r -> Just (E k p x, merge m l r)---- | Return a list of elements ordered by key whose priorities are at most @pt@,--- and the rest of the queue stripped of these elements.  The returned list of--- elements can be in any order: no guarantees there.-{-# INLINABLE atMost #-}-atMost :: Prio -> IntPSQ v -> ([Elem v], IntPSQ v)-atMost pt t0 = go [] t0-  where-    go acc t = case t of-        Nil             -> (acc, t)-        Tip k p x-            | p > pt    -> (acc, t)-            | otherwise -> ((E k p x) : acc, Nil)--        Bin k p x m l r-            | p > pt    -> (acc, t)-            | otherwise ->-                let (acc',  l') = go acc  l-                    (acc'', r') = go acc' r-                in  ((E k p x) : acc'', merge m l' r')------------------------------------------------------------------------------------ Traversal----------------------------------------------------------------------------------- | Internal function that merges two *disjoint* 'IntPSQ's that share the--- same prefix mask.-{-# INLINABLE merge #-}-merge :: Mask -> IntPSQ v -> IntPSQ v -> IntPSQ v-merge m l r = case l of-    Nil -> r--    Tip lk lp lx ->-      case r of-        Nil                     -> l-        Tip rk rp rx-          | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r-          | otherwise           -> Bin rk rp rx m l   Nil-        Bin rk rp rx rm rl rr-          | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r-          | otherwise           -> Bin rk rp rx m l   (merge rm rl rr)--    Bin lk lp lx lm ll lr ->-      case r of-        Nil                     -> l-        Tip rk rp rx-          | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r-          | otherwise           -> Bin rk rp rx m l                Nil-        Bin rk rp rx rm rl rr-          | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r-          | otherwise           -> Bin rk rp rx m l                (merge rm rl rr)
− GHC/Event/Poll.hsc 
@@ -1,207 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE GeneralizedNewtypeDeriving-           , NoImplicitPrelude-           , BangPatterns-  #-}--module GHC.Event.Poll-    (-      new-    , available-    ) where--#include "EventConfig.h"--#if !defined(HAVE_POLL_H)-import GHC.Base-import qualified GHC.Event.Internal as E--new :: IO E.Backend-new = errorWithoutStackTrace "Poll back end not implemented for this platform"--available :: Bool-available = False-{-# INLINE available #-}-#else-#include <poll.h>--import Control.Concurrent.MVar (MVar, newMVar, swapMVar)-import Data.Bits (Bits, FiniteBits, (.|.), (.&.))-import Foreign.C.Types (CInt(..), CShort(..))-import Foreign.Ptr (Ptr)-import Foreign.Storable (Storable(..))-import GHC.Base-import GHC.Conc.Sync (withMVar)-import GHC.Enum (maxBound)-import GHC.Num (Num(..))-import GHC.Real (fromIntegral, div)-import GHC.Show (Show)-import System.Posix.Types (Fd(..), CNfds(..))--import qualified GHC.Event.Array as A-import qualified GHC.Event.Internal as E--available :: Bool-available = True-{-# INLINE available #-}--data Poll = Poll {-      pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd))-    , pollFd      :: {-# UNPACK #-} !(A.Array PollFd)-    }--new :: IO E.Backend-new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`-      liftM2 Poll (newMVar =<< A.empty) A.empty--modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool-modifyFd p fd oevt nevt =-  withMVar (pollChanges p) $ \ary -> do-    A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)-    return True--modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool-modifyFdOnce = errorWithoutStackTrace "modifyFdOnce not supported in Poll backend"--reworkFd :: Poll -> PollFd -> IO ()-reworkFd p (PollFd fd npevt opevt) = do-  let ary = pollFd p-  if opevt == 0-    then A.snoc ary $ PollFd fd npevt 0-    else do-      found <- A.findIndex ((== fd) . pfdFd) ary-      case found of-        Nothing        -> errorWithoutStackTrace "reworkFd: event not found"-        Just (i,_)-          | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0-          | otherwise  -> A.removeAt ary i--poll :: Poll-     -> Maybe E.Timeout-     -> (Fd -> E.Event -> IO ())-     -> IO Int-poll p mtout f = do-  let a = pollFd p-  mods <- swapMVar (pollChanges p) =<< A.empty-  A.forM_ mods (reworkFd p)-  n <- A.useAsPtr a $ \ptr len ->-    E.throwErrnoIfMinus1NoRetry "c_poll" $-    case mtout of-      Just tout ->-        c_pollLoop ptr (fromIntegral len) (fromTimeout tout)-      Nothing   ->-        c_poll_unsafe ptr (fromIntegral len) 0-  when (n /= 0) $-    A.loop a 0 $ \i e -> do-      let r = pfdRevents e-      if r /= 0-        then do f (pfdFd e) (toEvent r)-                let i' = i + 1-                return (i', i' == n)-        else return (i, True)-  return (fromIntegral n)-  where-    -- The poll timeout is specified as an Int, but c_poll takes a CInt. These-    -- can't be safely coerced as on many systems (e.g. x86_64) CInt has a-    -- maxBound of (2^32 - 1), even though Int may have a significantly higher-    -- bound.-    ---    -- This function deals with timeouts greater than maxBound :: CInt, by-    -- looping until c_poll returns a non-zero value (0 indicates timeout-    -- expired) OR the full timeout has passed.-    c_pollLoop :: Ptr PollFd -> CNfds -> Int -> IO CInt-    c_pollLoop ptr len tout-        | isShortTimeout = c_poll ptr len (fromIntegral tout)-        | otherwise = do-            result <- c_poll ptr len (fromIntegral maxPollTimeout)-            if result == 0-               then c_pollLoop ptr len (fromIntegral (tout - maxPollTimeout))-               else return result-        where-          -- maxPollTimeout is smaller than 0 IFF Int is smaller than CInt.-          -- This means any possible Int input to poll can be safely directly-          -- converted to CInt.-          isShortTimeout = tout <= maxPollTimeout || maxPollTimeout < 0--    -- We need to account for 3 cases:-    --     1. Int and CInt are of equal size.-    --     2. Int is larger than CInt-    --     3. Int is smaller than CInt-    ---    -- In case 1, the value of maxPollTimeout will be the maxBound of Int.-    ---    -- In case 2, the value of maxPollTimeout will be the maxBound of CInt,-    -- which is the largest value accepted by c_poll. This will result in-    -- c_pollLoop recursing if the provided timeout is larger.-    ---    -- In case 3, "fromIntegral (maxBound :: CInt) :: Int" will result in a-    -- negative Int. This will cause isShortTimeout to be true and result in-    -- the timeout being directly converted to a CInt.-    maxPollTimeout :: Int-    maxPollTimeout = fromIntegral (maxBound :: CInt)--fromTimeout :: E.Timeout -> Int-fromTimeout E.Forever     = -1-fromTimeout (E.Timeout s) = fromIntegral $ s `divRoundUp` 1000000-  where-    divRoundUp num denom = (num + denom - 1) `div` denom--data PollFd = PollFd {-      pfdFd      :: {-# UNPACK #-} !Fd-    , pfdEvents  :: {-# UNPACK #-} !Event-    , pfdRevents :: {-# UNPACK #-} !Event-    } deriving Show -- ^ @since 4.4.0.0--newtype Event = Event CShort-    deriving ( Eq         -- ^ @since 4.4.0.0-             , Show       -- ^ @since 4.4.0.0-             , Num        -- ^ @since 4.4.0.0-             , Storable   -- ^ @since 4.4.0.0-             , Bits       -- ^ @since 4.4.0.0-             , FiniteBits -- ^ @since 4.7.0.0-             )--#{enum Event, Event- , pollIn    = POLLIN- , pollOut   = POLLOUT- , pollErr   = POLLERR- , pollHup   = POLLHUP- }--fromEvent :: E.Event -> Event-fromEvent e = remap E.evtRead  pollIn .|.-              remap E.evtWrite pollOut-  where remap evt to-            | e `E.eventIs` evt = to-            | otherwise         = 0--toEvent :: Event -> E.Event-toEvent e = remap (pollIn .|. pollErr .|. pollHup)  E.evtRead `mappend`-            remap (pollOut .|. pollErr .|. pollHup) E.evtWrite-  where remap evt to-            | e .&. evt /= 0 = to-            | otherwise      = mempty---- | @since 4.3.1.0-instance Storable PollFd where-    sizeOf _    = #size struct pollfd-    alignment _ = alignment (undefined :: CInt)--    peek ptr = do-      fd <- #{peek struct pollfd, fd} ptr-      events <- #{peek struct pollfd, events} ptr-      revents <- #{peek struct pollfd, revents} ptr-      let !pollFd' = PollFd fd events revents-      return pollFd'--    poke ptr p = do-      #{poke struct pollfd, fd} ptr (pfdFd p)-      #{poke struct pollfd, events} ptr (pfdEvents p)-      #{poke struct pollfd, revents} ptr (pfdRevents p)--foreign import ccall safe "poll.h poll"-    c_poll :: Ptr PollFd -> CNfds -> CInt -> IO CInt--foreign import ccall unsafe "poll.h poll"-    c_poll_unsafe :: Ptr PollFd -> CNfds -> CInt -> IO CInt-#endif /* defined(HAVE_POLL_H) */
− GHC/Event/Thread.hs 
@@ -1,422 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}--module GHC.Event.Thread-    ( getSystemEventManager-    , getSystemTimerManager-    , ensureIOManagerIsRunning-    , ioManagerCapabilitiesChanged-    , threadWaitRead-    , threadWaitWrite-    , threadWaitReadSTM-    , threadWaitWriteSTM-    , closeFdWith-    , threadDelay-    , registerDelay-    , blockedOnBadFD -- used by RTS-    ) where--- TODO: Use new Windows I/O manager-import Control.Exception (finally, SomeException, toException)-import Data.Foldable (forM_, mapM_, sequence_)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef)-import Data.Maybe (fromMaybe)-import Data.Tuple (snd)-import Foreign.C.Error (eBADF, errnoToIOError)-import Foreign.C.Types (CInt(..), CUInt(..))-import Foreign.Ptr (Ptr)-import GHC.Base-import GHC.List (zipWith, zipWith3)-import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,-                      labelThread, modifyMVar_, withMVar, newTVar, sharedCAF,-                      getNumCapabilities, threadCapability, myThreadId, forkOn,-                      threadStatus, writeTVar, newTVarIO, readTVar, retry,-                      throwSTM, STM, yield)-import GHC.IO (mask_, uninterruptibleMask_, onException)-import GHC.IO.Exception (ioError)-import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,-                    boundsIOArray)-import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)-import GHC.Event.Control (controlWriteFd)-import GHC.Event.Internal (eventIs, evtClose)-import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,-                             new, registerFd, unregisterFd_)-import qualified GHC.Event.Manager as M-import qualified GHC.Event.TimerManager as TM-import GHC.Ix (inRange)-import GHC.Num ((-), (+))-import GHC.Real (fromIntegral)-import GHC.Show (showSignedInt)-import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Types (Fd)---- | Suspends the current thread for a given number of microseconds--- (GHC only).------ There is no guarantee that the thread will be rescheduled promptly--- when the delay has expired, but the thread will never continue to--- run /earlier/ than specified.-threadDelay :: Int -> IO ()-threadDelay usecs = mask_ $ do-  mgr <- getSystemTimerManager-  m <- newEmptyMVar-  reg <- TM.registerTimeout mgr usecs (putMVar m ())-  takeMVar m `onException` TM.unregisterTimeout mgr reg---- | Set the value of returned TVar to True after a given number of--- microseconds. The caveats associated with threadDelay also apply.----registerDelay :: Int -> IO (TVar Bool)-registerDelay usecs = do-  t <- atomically $ newTVar False-  mgr <- getSystemTimerManager-  _ <- TM.registerTimeout mgr usecs . atomically $ writeTVar t True-  return t---- | Block the current thread until data is available to read from the--- given file descriptor.------ This will throw an 'Prelude.IOError' if the file descriptor was closed--- while this thread was blocked.  To safely close a file descriptor--- that has been used with 'threadWaitRead', use 'closeFdWith'.-threadWaitRead :: Fd -> IO ()-threadWaitRead = threadWait evtRead-{-# INLINE threadWaitRead #-}---- | Block the current thread until the given file descriptor can--- accept data to write.------ This will throw an 'Prelude.IOError' if the file descriptor was closed--- while this thread was blocked.  To safely close a file descriptor--- that has been used with 'threadWaitWrite', use 'closeFdWith'.-threadWaitWrite :: Fd -> IO ()-threadWaitWrite = threadWait evtWrite-{-# INLINE threadWaitWrite #-}---- | Close a file descriptor in a concurrency-safe way.------ Any threads that are blocked on the file descriptor via--- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having--- IO exceptions thrown.-closeFdWith :: (Fd -> IO ())        -- ^ Action that performs the close.-            -> Fd                   -- ^ File descriptor to close.-            -> IO ()-closeFdWith close fd = close_loop-  where-    finish mgr table cbApp = putMVar (M.callbackTableVar mgr fd) table >> cbApp-    zipWithM f xs ys = sequence (zipWith f xs ys)-      -- The array inside 'eventManager' can be swapped out at any time, see-      -- 'ioManagerCapabilitiesChanged'. See #21651. We detect this case by-      -- checking the array bounds before and after. When such a swap has-      -- happened we cleanup and try again-    close_loop = do-      eventManagerArray <- readIORef eventManager-      let ema_bounds@(low, high) = boundsIOArray eventManagerArray-      mgrs <- flip mapM [low..high] $ \i -> do-        Just (_,!mgr) <- readIOArray eventManagerArray i-        return mgr--      -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time.-      -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have-      -- to use uninterruptible mask.-      join $ uninterruptibleMask_ $ do-        tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd-        new_ema_bounds <- boundsIOArray `fmap` readIORef eventManager-        -- Here we exploit Note [The eventManager Array]-        if new_ema_bounds /= ema_bounds-          then do-            -- the array has been modified.-            -- mgrs still holds the right EventManagers, by the Note.-            -- new_ema_bounds must be larger than ema_bounds, by the note.-            -- return the MVars we took and try again-            sequence_ $ zipWith (\mgr table -> finish mgr table (pure ())) mgrs tables-            pure close_loop-          else do-            -- We surely have taken all the appropriate MVars. Even if the array-            -- has been swapped, our mgrs is still correct.-            -- Remove the Fd from all callback tables, close the Fd, and run all-            -- callbacks.-            cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables-            close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps)-            pure (pure ())--threadWait :: Event -> Fd -> IO ()-threadWait evt fd = mask_ $ do-  m <- newEmptyMVar-  mgr <- getSystemEventManager_-  reg <- registerFd mgr (\_ e -> putMVar m e) fd evt M.OneShot-  evt' <- takeMVar m `onException` unregisterFd_ mgr reg-  if evt' `eventIs` evtClose-    then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing-    else return ()---- used at least by RTS in 'select()' IO manager backend-blockedOnBadFD :: SomeException-blockedOnBadFD = toException $ errnoToIOError "awaitEvent" eBADF Nothing Nothing--threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())-threadWaitSTM evt fd = mask_ $ do-  m <- newTVarIO Nothing-  mgr <- getSystemEventManager_-  reg <- registerFd mgr (\_ e -> atomically (writeTVar m (Just e))) fd evt M.OneShot-  let waitAction =-        do mevt <- readTVar m-           case mevt of-             Nothing -> retry-             Just evt' ->-               if evt' `eventIs` evtClose-               then throwSTM $ errnoToIOError "threadWaitSTM" eBADF Nothing Nothing-               else return ()-  return (waitAction, unregisterFd_ mgr reg >> return ())---- | Allows a thread to use an STM action to wait for a file descriptor to be readable.--- The STM action will retry until the file descriptor has data ready.--- The second element of the return value pair is an IO action that can be used--- to deregister interest in the file descriptor.------ The STM action will throw an 'Prelude.IOError' if the file descriptor was closed--- while the STM action is being executed.  To safely close a file descriptor--- that has been used with 'threadWaitReadSTM', use 'closeFdWith'.-threadWaitReadSTM :: Fd -> IO (STM (), IO ())-threadWaitReadSTM = threadWaitSTM evtRead-{-# INLINE threadWaitReadSTM #-}---- | Allows a thread to use an STM action to wait until a file descriptor can accept a write.--- The STM action will retry while the file until the given file descriptor can accept a write.--- The second element of the return value pair is an IO action that can be used to deregister--- interest in the file descriptor.------ The STM action will throw an 'Prelude.IOError' if the file descriptor was closed--- while the STM action is being executed.  To safely close a file descriptor--- that has been used with 'threadWaitWriteSTM', use 'closeFdWith'.-threadWaitWriteSTM :: Fd -> IO (STM (), IO ())-threadWaitWriteSTM = threadWaitSTM evtWrite-{-# INLINE threadWaitWriteSTM #-}----- | Retrieve the system event manager for the capability on which the--- calling thread is running.------ This function always returns 'Just' the current thread's event manager--- when using the threaded RTS and 'Nothing' otherwise.-getSystemEventManager :: IO (Maybe EventManager)-getSystemEventManager = do-  t <- myThreadId-  eventManagerArray <- readIORef eventManager-  let r = boundsIOArray eventManagerArray-  (cap, _) <- threadCapability t-  -- It is possible that we've just increased the number of capabilities and the-  -- new EventManager has not yet been constructed by-  -- 'ioManagerCapabilitiesChanged'. We expect this to happen very rarely.-  -- T21561 exercises this.-  -- Two options to proceed:-  --  1) return the EventManager for capability 0. This is guaranteed to exist,-  --     and "shouldn't" cause any correctness issues.-  --  2) Busy wait, with or without a call to 'yield'. This can't deadlock,-  --     because we must be on a brand capability and there must be a call to-  --     'ioManagerCapabilitiesChanged' pending.-  ---  -- We take the second option, with the yield, judging it the most robust.-  if not (inRange r cap)-    then yield >> getSystemEventManager-    else fmap snd `fmap` readIOArray eventManagerArray cap--getSystemEventManager_ :: IO EventManager-getSystemEventManager_ = do-  Just mgr <- getSystemEventManager-  return mgr-{-# INLINE getSystemEventManager_ #-}--foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"-    getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)---- Note [The eventManager Array]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- A mutable array holding the current EventManager for each capability--- An entry is Nothing only while the eventmanagers are initialised, see--- 'startIOManagerThread' and 'ioManagerCapabilitiesChanged'.--- The 'ThreadId' at array position 'cap'  will have been 'forkOn'ed capabality--- 'cap'.--- The array will be swapped with newer arrays when the number of capabilities--- changes(via 'setNumCapabilities'). However:---   * the size of the arrays will never decrease; and---   * The 'EventManager's in the array are not replaced with other---     'EventManager' constructors.------ This is a similar strategy as the rts uses for it's--- capabilities array (n_capabilities is the size of the array,--- enabled_capabilities' is the number of active capabilities).-eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager)))-eventManager = unsafePerformIO $ do-    numCaps <- getNumCapabilities-    eventManagerArray <- newIOArray (0, numCaps - 1) Nothing-    em <- newIORef eventManagerArray-    sharedCAF em getOrSetSystemEventThreadEventManagerStore-{-# NOINLINE eventManager #-}--numEnabledEventManagers :: IORef Int-numEnabledEventManagers = unsafePerformIO $ newIORef 0-{-# NOINLINE numEnabledEventManagers #-}--foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"-    getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)---- | The ioManagerLock protects the 'eventManager' value:--- Only one thread at a time can start or shutdown event managers.-{-# NOINLINE ioManagerLock #-}-ioManagerLock :: MVar ()-ioManagerLock = unsafePerformIO $ do-   m <- newMVar ()-   sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore--getSystemTimerManager :: IO TM.TimerManager-getSystemTimerManager =-  fromMaybe err `fmap` readIORef timerManager-    where-      err = error "GHC.Event.Thread.getSystemTimerManager: the TimerManager requires linking against the threaded runtime"--foreign import ccall unsafe "getOrSetSystemTimerThreadEventManagerStore"-    getOrSetSystemTimerThreadEventManagerStore :: Ptr a -> IO (Ptr a)--timerManager :: IORef (Maybe TM.TimerManager)-timerManager = unsafePerformIO $ do-    em <- newIORef Nothing-    sharedCAF em getOrSetSystemTimerThreadEventManagerStore-{-# NOINLINE timerManager #-}--foreign import ccall unsafe "getOrSetSystemTimerThreadIOManagerThreadStore"-    getOrSetSystemTimerThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)--{-# NOINLINE timerManagerThreadVar #-}-timerManagerThreadVar :: MVar (Maybe ThreadId)-timerManagerThreadVar = unsafePerformIO $ do-   m <- newMVar Nothing-   sharedCAF m getOrSetSystemTimerThreadIOManagerThreadStore--ensureIOManagerIsRunning :: IO ()-ensureIOManagerIsRunning-  | not threaded = return ()-  | otherwise = do-      startIOManagerThreads-      startTimerManagerThread--startIOManagerThreads :: IO ()-startIOManagerThreads =-  withMVar ioManagerLock $ \_ -> do-    eventManagerArray <- readIORef eventManager-    let (_, high) = boundsIOArray eventManagerArray-    mapM_ (startIOManagerThread eventManagerArray) [0..high]-    writeIORef numEnabledEventManagers (high+1)--show_int :: Int -> String-show_int i = showSignedInt 0 i ""--restartPollLoop :: EventManager -> Int -> IO ThreadId-restartPollLoop mgr i = do-  M.release mgr-  !t <- forkOn i $ loop mgr-  labelThread t ("IOManager on cap " ++ show_int i)-  return t--startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager))-                        -> Int-                        -> IO ()-startIOManagerThread eventManagerArray i = do-  let create = do-        !mgr <- new-        !t <- forkOn i $ do-                c_setIOManagerControlFd-                  (fromIntegral i)-                  (fromIntegral $ controlWriteFd $ M.emControl mgr)-                loop mgr-        labelThread t ("IOManager on cap " ++ show_int i)-        writeIOArray eventManagerArray i (Just (t,mgr))-  old <- readIOArray eventManagerArray i-  case old of-    Nothing     -> create-    Just (t,em) -> do-      s <- threadStatus t-      case s of-        ThreadFinished -> create-        ThreadDied     -> do-          -- Sanity check: if the thread has died, there is a chance-          -- that event manager is still alive. This could happened during-          -- the fork, for example. In this case we should clean up-          -- open pipes and everything else related to the event manager.-          -- See #4449-          c_setIOManagerControlFd (fromIntegral i) (-1)-          M.cleanup em-          create-        _other         -> return ()--startTimerManagerThread :: IO ()-startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do-  let create = do-        !mgr <- TM.new-        c_setTimerManagerControlFd-          (fromIntegral $ controlWriteFd $ TM.emControl mgr)-        writeIORef timerManager $ Just mgr-        !t <- forkIO $ TM.loop mgr-        labelThread t "TimerManager"-        return $ Just t-  case old of-    Nothing            -> create-    st@(Just t) -> do-      s <- threadStatus t-      case s of-        ThreadFinished -> create-        ThreadDied     -> do-          -- Sanity check: if the thread has died, there is a chance-          -- that event manager is still alive. This could happened during-          -- the fork, for example. In this case we should clean up-          -- open pipes and everything else related to the event manager.-          -- See #4449-          mem <- readIORef timerManager-          _ <- case mem of-                 Nothing -> return ()-                 Just em -> do c_setTimerManagerControlFd (-1)-                               TM.cleanup em-          create-        _other         -> return st--foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool--ioManagerCapabilitiesChanged :: IO ()-ioManagerCapabilitiesChanged =-  withMVar ioManagerLock $ \_ -> do-    new_n_caps <- getNumCapabilities-    numEnabled <- readIORef numEnabledEventManagers-    writeIORef numEnabledEventManagers new_n_caps-    eventManagerArray <- readIORef eventManager-    let (_, high) = boundsIOArray eventManagerArray-    let old_n_caps = high + 1-    if new_n_caps > old_n_caps-      then do new_eventManagerArray <- newIOArray (0, new_n_caps - 1) Nothing--              -- copy the existing values into the new array:-              forM_ [0..high] $ \i -> do-                Just (tid,mgr) <- readIOArray eventManagerArray i-                if i < numEnabled-                  then writeIOArray new_eventManagerArray i (Just (tid,mgr))-                  else do tid' <- restartPollLoop mgr i-                          writeIOArray new_eventManagerArray i (Just (tid',mgr))--              -- create new IO managers for the new caps:-              forM_ [old_n_caps..new_n_caps-1] $-                startIOManagerThread new_eventManagerArray--              -- update the event manager array reference:-              atomicWriteIORef eventManager new_eventManagerArray-              -- We need an atomic write here because 'eventManager' is accessed-              -- unsynchronized in 'getSystemEventManager' and 'closeFdWith'-      else when (new_n_caps > numEnabled) $-            forM_ [numEnabled..new_n_caps-1] $ \i -> do-              Just (_,mgr) <- readIOArray eventManagerArray i-              tid <- restartPollLoop mgr i-              writeIOArray eventManagerArray i (Just (tid,mgr))---- Used to tell the RTS how it can send messages to the I/O manager.-foreign import ccall unsafe "setIOManagerControlFd"-   c_setIOManagerControlFd :: CUInt -> CInt -> IO ()--foreign import ccall unsafe "setTimerManagerControlFd"-   c_setTimerManagerControlFd :: CInt -> IO ()
− GHC/Event/TimeOut.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}----------------------------------------------------------------------------------- |--- Module      :  GHC.Event.TimeOut--- Copyright   :  (c) Tamar Christina 2018--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Common Timer definitions shared between WinIO and RIO.-------------------------------------------------------------------------------------module GHC.Event.TimeOut where--import GHC.IO-import GHC.Base--import qualified GHC.Event.PSQ as Q-import GHC.Event.Unique (Unique)---- | A priority search queue, with timeouts as priorities.-type TimeoutQueue = Q.PSQ TimeoutCallback---- |--- Warning: since the 'TimeoutCallback' is called from the I/O manager, it must--- not throw an exception or block for a long period of time.  In particular,--- be wary of 'Control.Exception.throwTo' and 'Control.Concurrent.killThread':--- if the target thread is making a foreign call, these functions will block--- until the call completes.-type TimeoutCallback = IO ()---- | An edit to apply to a 'TimeoutQueue'.-type TimeoutEdit = TimeoutQueue -> TimeoutQueue---- | A timeout registration cookie.-newtype TimeoutKey = TK Unique-    deriving (Eq, Ord)
− GHC/Event/TimerManager.hs 
@@ -1,255 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}---- TODO: use the new Windows IO manager-module GHC.Event.TimerManager-    ( -- * Types-      TimerManager--      -- * Creation-    , new-    , newWith-    , newDefaultBackend-    , emControl--      -- * Running-    , finished-    , loop-    , step-    , shutdown-    , cleanup-    , wakeManager--      -- * Registering interest in timeout events-    , TimeoutCallback-    , TimeoutKey-    , registerTimeout-    , updateTimeout-    , unregisterTimeout-    ) where--#include "EventConfig.h"----------------------------------------------------------------------------- Imports--import Control.Exception (finally)-import Data.Foldable (sequence_)-import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,-                   writeIORef)-import GHC.Base-import GHC.Clock (getMonotonicTimeNSec)-import GHC.Conc.Signal (runHandlers)-import GHC.Enum (maxBound)-import GHC.Num (Num(..))-import GHC.Real (quot, fromIntegral)-import GHC.Show (Show(..))-import GHC.Event.Control-import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))-import GHC.Event.Unique (UniqueSource, newSource, newUnique)-import GHC.Event.TimeOut-import System.Posix.Types (Fd)--import qualified GHC.Event.Internal as I-import qualified GHC.Event.PSQ as Q--#if defined(HAVE_POLL)-import qualified GHC.Event.Poll   as Poll-#else-# error not implemented for this operating system-#endif----------------------------------------------------------------------------- Types--data State = Created-           | Running-           | Dying-           | Finished-             deriving ( Eq   -- ^ @since 4.7.0.0-                      , Show -- ^ @since 4.7.0.0-                      )---- | The event manager state.-data TimerManager = TimerManager-    { emBackend      :: !Backend-    , emTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)-    , emState        :: {-# UNPACK #-} !(IORef State)-    , emUniqueSource :: {-# UNPACK #-} !UniqueSource-    , emControl      :: {-# UNPACK #-} !Control-    }----------------------------------------------------------------------------- Creation--handleControlEvent :: TimerManager -> Fd -> Event -> IO ()-handleControlEvent mgr fd _evt = do-  msg <- readControlMessage (emControl mgr) fd-  case msg of-    CMsgWakeup      -> return ()-    CMsgDie         -> writeIORef (emState mgr) Finished-    CMsgSignal fp s -> runHandlers fp s--newDefaultBackend :: IO Backend-#if defined(HAVE_POLL)-newDefaultBackend = Poll.new-#else-newDefaultBackend = errorWithoutStackTrace "no back end for this platform"-#endif---- | Create a new event manager.-new :: IO TimerManager-new = newWith =<< newDefaultBackend--newWith :: Backend -> IO TimerManager-newWith be = do-  timeouts <- newIORef Q.empty-  ctrl <- newControl True-  state <- newIORef Created-  us <- newSource-  _ <- mkWeakIORef state $ do-               st <- atomicModifyIORef' state $ \s -> (Finished, s)-               when (st /= Finished) $ do-                 I.delete be-                 closeControl ctrl-  let mgr = TimerManager { emBackend = be-                         , emTimeouts = timeouts-                         , emState = state-                         , emUniqueSource = us-                         , emControl = ctrl-                         }-  _ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead-  _ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead-  return mgr---- | Asynchronously shuts down the event manager, if running.-shutdown :: TimerManager -> IO ()-shutdown mgr = do-  state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)-  when (state == Running) $ sendDie (emControl mgr)--finished :: TimerManager -> IO Bool-finished mgr = (== Finished) `liftM` readIORef (emState mgr)--cleanup :: TimerManager -> IO ()-cleanup mgr = do-  writeIORef (emState mgr) Finished-  I.delete (emBackend mgr)-  closeControl (emControl mgr)----------------------------------------------------------------------------- Event loop---- | Start handling events.  This function loops until told to stop,--- using 'shutdown'.------ /Note/: This loop can only be run once per 'TimerManager', as it--- closes all of its control resources when it finishes.-loop :: TimerManager -> IO ()-loop mgr = do-  state <- atomicModifyIORef' (emState mgr) $ \s -> case s of-    Created -> (Running, s)-    _       -> (s, s)-  case state of-    Created -> go `finally` cleanup mgr-    Dying   -> cleanup mgr-    _       -> do cleanup mgr-                  errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++-                      show state- where-  go = do running <- step mgr-          when running go--step :: TimerManager -> IO Bool-step mgr = do-  timeout <- mkTimeout-  _ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)-  state <- readIORef (emState mgr)-  state `seq` return (state == Running)- where--  -- | Call all expired timer callbacks and return the time to the-  -- next timeout.-  mkTimeout :: IO Timeout-  mkTimeout = do-      now <- getMonotonicTimeNSec-      (expired, timeout) <- atomicModifyIORef' (emTimeouts mgr) $ \tq ->-           let (expired, tq') = Q.atMost now tq-               timeout = case Q.minView tq' of-                 Nothing             -> Forever-                 Just (Q.E _ t _, _) ->-                     -- This value will always be positive since the call-                     -- to 'atMost' above removed any timeouts <= 'now'-                     let t' = t - now in t' `seq` Timeout t'-           in (tq', (expired, timeout))-      sequence_ $ map Q.value expired-      return timeout---- | Wake up the event manager.-wakeManager :: TimerManager -> IO ()-wakeManager mgr = sendWakeup (emControl mgr)----------------------------------------------------------------------------- Registering interest in timeout events--expirationTime :: Int -> IO Q.Prio-expirationTime us = do-    now <- getMonotonicTimeNSec-    let expTime-          -- Currently we treat overflows by clamping to maxBound. If humanity-          -- still exists in 2500 CE we will ned to be a bit more careful here.-          -- See #15158.-          | (maxBound - now) `quot` 1000 < fromIntegral us  = maxBound-          | otherwise                                       = now + ns-          where ns = 1000 * fromIntegral us-    return expTime---- | Register a timeout in the given number of microseconds.  The--- returned 'TimeoutKey' can be used to later unregister or update the--- timeout.  The timeout is automatically unregistered after the given--- time has passed.-registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey-registerTimeout mgr us cb = do-  !key <- newUnique (emUniqueSource mgr)-  if us <= 0 then cb-    else do-      expTime <- expirationTime us--      -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It-      -- doesn't because we just generated it from a unique supply.-      editTimeouts mgr (Q.unsafeInsertNew key expTime cb)-  return $ TK key---- | Unregister an active timeout.-unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()-unregisterTimeout mgr (TK key) =-  editTimeouts mgr (Q.delete key)---- | Update an active timeout to fire in the given number of--- microseconds.-updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()-updateTimeout mgr (TK key) us = do-  expTime <- expirationTime us-  editTimeouts mgr (Q.adjust (const expTime) key)--editTimeouts :: TimerManager -> TimeoutEdit -> IO ()-editTimeouts mgr g = do-  wake <- atomicModifyIORef' (emTimeouts mgr) f-  when wake (wakeManager mgr)-  where-    f q = (q', wake)-      where-        q' = g q-        wake = case Q.minView q of-                Nothing -> True-                Just (Q.E _ t0 _, _) ->-                  case Q.minView q' of-                    Just (Q.E _ t1 _, _) ->-                      -- don't wake the manager if the-                      -- minimum element didn't change.-                      t0 /= t1-                    _ -> True
− GHC/Event/Unique.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, MagicHash,-  NoImplicitPrelude, UnboxedTuples #-}--module GHC.Event.Unique-    (-      UniqueSource-    , Unique(..)-    , newSource-    , newUnique-    ) where--import GHC.Base-import GHC.Num(Num)-import GHC.Show(Show(..))--#include "MachDeps.h"--data UniqueSource = US (MutableByteArray# RealWorld)--newtype Unique = Unique { asInt :: Int }-    deriving ( Eq  -- ^ @since 4.4.0.0-             , Ord -- ^ @since 4.4.0.0-             , Num -- ^ @since 4.4.0.0-             )---- | @since 4.3.1.0-instance Show Unique where-    show = show . asInt--newSource :: IO UniqueSource-newSource = IO $ \s ->-  case newByteArray# size s of-    (# s', mba #) -> (# s', US mba #)-  where-    !(I# size) = SIZEOF_HSINT--newUnique :: UniqueSource -> IO Unique-newUnique (US mba) = IO $ \s ->-  case fetchAddIntArray# mba 0# 1# s of-    (# s', a #) -> (# s', Unique (I# a) #)-{-# INLINE newUnique #-}
− GHC/Event/Windows.hsc 
@@ -1,1297 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  GHC.Event.Windows--- Copyright   :  (c) Tamar Christina 2018--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ WinIO Windows event manager.-------------------------------------------------------------------------------------module GHC.Event.Windows (-    -- * Manager-    Manager,-    getSystemManager,-    interruptSystemManager,-    wakeupIOManager,-    processRemoteCompletion,--    -- * Overlapped I/O-    associateHandle,-    associateHandle',-    withOverlapped,-    withOverlappedEx,-    StartCallback,-    StartIOCallback,-    CbResult(..),-    CompletionCallback,-    LPOVERLAPPED,--    -- * Timeouts-    TimeoutCallback,-    TimeoutKey,-    Seconds,-    registerTimeout,-    updateTimeout,-    unregisterTimeout,--    -- * Utilities-    withException,-    ioSuccess,-    ioFailed,-    ioFailedAny,-    getLastError,--    -- * I/O Result type-    IOResult(..),--    -- * I/O Event notifications-    HandleData (..), -- seal for release-    HandleKey (handleValue),-    registerHandle,-    unregisterHandle,--    -- * Console events-    module GHC.Event.Windows.ConsoleEvent-) where---- define DEBUG 1---- #define DEBUG_TRACE 1--##include "windows_cconv.h"-#include <windows.h>-#include <ntstatus.h>-#include <Rts.h>-#include "winio_structs.h"---- There doesn't seem to be  GHC.* import for these-import Control.Concurrent.MVar (modifyMVar)-import {-# SOURCE #-} Control.Concurrent (forkOS)-import Data.Semigroup.Internal (stimesMonoid)-import Data.Foldable (mapM_, length, forM_)-import Data.Maybe (isJust, maybe)--import GHC.Event.Windows.Clock   (Clock, Seconds, getClock, getTime)-import GHC.Event.Windows.FFI     (LPOVERLAPPED, OVERLAPPED_ENTRY(..),-                                  CompletionData(..), CompletionCallback,-                                  withRequest)-import GHC.Event.Windows.ManagedThreadPool-import GHC.Event.Internal.Types-import GHC.Event.Unique-import GHC.Event.TimeOut-import GHC.Event.Windows.ConsoleEvent-import qualified GHC.Event.Windows.FFI    as FFI-import qualified GHC.Event.PSQ            as Q-import qualified GHC.Event.IntTable       as IT-import qualified GHC.Event.Internal as I--import GHC.MVar-import GHC.Exception as E-import GHC.IORef-import GHC.Maybe-import GHC.Word-import GHC.OldList (deleteBy)-import Foreign-import qualified GHC.Event.Array    as A-import GHC.Base-import GHC.Conc.Sync-import GHC.IO-import GHC.IOPort-import GHC.Num-import GHC.Real-import GHC.Enum (maxBound)-import GHC.Windows-import GHC.List (null)-import Text.Show--#if defined(DEBUG)-import Foreign.C-import System.Posix.Internals (c_write)-import GHC.Conc.Sync (myThreadId)-#endif--import qualified GHC.Windows as Win32--#if defined(DEBUG_TRACE)-import {-# SOURCE #-} Debug.Trace (traceEventIO)-#endif---- Note [WINIO Manager design]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- This file contains the Windows I//O manager. Windows's IO subsystem is by--- design fully asynchronous, however there are multiple ways and interfaces--- to the async methods.------ The chosen Async interface for this implementation is using Completion Ports--- See also Note [Completion Ports]. The I/O manager uses a new interface added--- in Windows Vista called `GetQueuedCompletionStatusEx` which allows us to--- service multiple requests in one go.------ See https://docs.microsoft.com/en-us/windows-hardware/drivers/kernel/overview-of-the-windows-i-o-model--- and https://www.microsoftpressstore.com/articles/article.aspx?p=2201309&seqNum=3------ In order to understand this file, here is what you should know:--- We're using relatively new APIs that allow us to service multiple requests at--- the same time using one OS thread.  This happens using so called Completion--- ports.  All I/O actions get associated with one and the same completion port.------ The I/O manager itself has two mode of operation:--- 1) Threaded: We have N dedicated OS threads in the Haskell world that service---    completion requests. Everything is Handled 100% in view of the runtime.---    Whenever the OS has completions that need to be serviced it wakes up one---    one of the OS threads that are blocked in GetQueuedCompletionStatusEx and---    lets it proceed  with the list of completions that are finished. If more---    completions finish before the first list is done being processed then---    another thread is woken up.  These threads are associated with the I/O---    manager through the completion port.  If a thread blocks for any reason the---    OS I/O manager will wake up another thread blocked in GetQueuedCompletionStatusEx---    from the pool to finish processing the remaining entries.  This worker thread---    must be able to handle the---    fact that something else has finished the remainder of their queue or must---    have a guarantee to never block.  In this implementation we strive to---    never block.   This is achieved by not having the worker threads call out---    to any user code, and to have the IOPort synchronization primitive never---    block.   This means if the port is full the message is lost, however we---    have an invariant that the port can never be full and have a waiting---    receiver.  As such, dropping the message does not change anything as there---    will never be anyone to receive it. e.g. it is an impossible situation to---    land in.---    Note that it is valid (and perhaps expected) that at times two workers---    will receive the same requests to handle. We deal with this by using---    atomic operations to prevent race conditions. See processCompletion---    for details.--- 2) Non-threaded: We don't have any dedicated Haskell threads servicing---    I/O Requests. Instead we have an OS thread inside the RTS that gets---    notified of new requests and does the servicing.  When a request completes---    a Haskell thread is scheduled to run to finish off the processing of any---    completed requests. See Note [Non-Threaded WINIO design].------ These two modes of operations share the majority of the code and so they both--- support the same operations and fixing one will fix the other.--- Unlike MIO, we don't threat network I/O any differently than file I/O. Hence--- any network specific code is now only in the network package.------ See also Note [Completion Ports] which has some of the details which--- informed this design.------ Note [Threaded WINIO design]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The threaded WiNIO is designed around a simple blocking call that's called in--- a service loop in a dedicated thread: `GetQueuedCompletionStatusEx`.--- as such the loop is reasonably simple.  We're either servicing finished--- requests or blocking in `getQueuedCompletionStatusEx` waiting for new--- requests to arrive.------ Each time a Handle is made three important things happen that affect the I/O--- manager design:--- 1) Files are opened with the `FILE_FLAG_OVERLAPPED` flag, which instructs the---    OS that we will be doing purely asynchronous requests. See---    `GHC.IO.Windows.Handle.openFile`.  They are also opened with---    `FILE_FLAG_SEQUENTIAL_SCAN` to indicate to the OS that we want to optimize---    the access of the file for sequential access. (e.g. equivalent to MADVISE)--- 2) The created handle is associated with the I/O manager's completion port.---    This allows the I/O manager to be able to service I/O events from this---    handle.  See `associateHandle`.--- 3) File handles are additionally modified with two optimization flags:------    FILE_SKIP_COMPLETION_PORT_ON_SUCCESS: If the request can be serviced---    immediately, then do not queue the IRP (IO Request Packet) into the I/O---    manager waiting for us to service it later.  Instead service it---    immediately in the same call.  This is beneficial for two reasons:---    1) We don't have to block in the Haskell RTS.---    2) We save a bunch of work in the OS's I/O subsystem.---    The downside is though that we have to do a bunch of work to handle these---    cases.  This is abstracted away from the user by the `withOverlapped`---    function.---    This together with the buffering strategy mentioned above means we---    actually skip the I/O manager on quite a lot of I/O requests due to the---    value being in the cache.  Because of the Lazy I/O in Haskell, the time---    to read and decode the buffer of bytes is usually longer than the OS needs---    to read the next chunk, so we hit the FAST_IO IRP quite often.------    FILE_SKIP_SET_EVENT_ON_HANDLE: Since we will not be using an event object---    to monitor asynchronous completions, don't bother updating or checking for---    one.  This saves some precious cycles, especially on operations with very---    high number of I/O operations (e.g. servers.)------ So what does servicing a request actually mean.  As mentioned before the--- I/O manager will be blocked or servicing a request. In reality it doesn't--- always block till an I/O request has completed.  In cases where we have event--- timers, we block till the next timer's timeout.  This allows us to also--- service timers in the same loop.  The side effect of this is that we will--- exit the I/O wait sometimes without any completions.  Not really a problem--- but it's an important design decision.------ Every time we wait, we give a pre-allocated buffer of `n`--- `OVERLAPPED_ENTRIES` to the OS.  This means that in a single call we can--- service up to `n` I/O requests at a time.  The size of `n` is not fixed,--- anytime we dequeue `n` I/O requests in a single operation we double the--- buffer size, allowing the I/O manager to be able to scale up depending--- on the workload.  This buffer is kept alive throughout the lifetime of the--- program and is never freed until the I/O manager is shutting down.------ One very important property of the I/O subsystem is that each I/O request--- now requires an `OVERLAPPED` structure be given to the I/O manager.  See--- `withOverlappedEx`.  This buffer is used by the OS to fill in various state--- information. Throughout the duration of I/O call, this buffer MUST--- remain live.  The address is pinned by the kernel, which means that the--- pointer must remain accessible until `GetQueuedCompletionStatusEx` returns--- the completion associated with the handle and not just until the call to what--- ever I/O operation was used to initialize the I/O request returns.--- The only exception to this is when the request has hit the FAST_IO path, in--- which case it has skipped the I/O queue and so can be freed immediately after--- reading the results from it.------ To prevent having to lookup the Haskell payload in a shared state after the--- request completes we attach it as part of the I/O request by extending the--- `OVERLAPPED` structure.  Instead of passing an `OVERLAPPED` structure to the--- Windows API calls we instead pass a `HASKELL_OVERLAPPED` struct which has--- as the first element an `OVERLAPPED structure.  This means when a request is--- done all we need to do is cast the pointer back to `HASKELL_OVERLAPPED` and--- read the accompanying data.  This also means we don't have a global lock and--- so can scale much easier.------- ------------------------------------------------------------------------------ I/O manager global thread---- When running GHCi we still want to ensure we still only have one--- io manager thread, even if base is loaded twice. See the docs for--- sharedCAF for how this is done.--{-# NOINLINE ioManagerThread #-}-ioManagerThread :: MVar (Maybe ThreadId)-ioManagerThread = unsafePerformIO $ do-   m <- newMVar Nothing-   sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore--foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"-  getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)---- ------------------------------------------------------------------------------ Non-threaded I/O manager callback hooks. See `ASyncWinIO.c`--foreign import ccall safe "registerIOCPHandle"-  registerIOCPHandle :: FFI.IOCP -> IO ()--foreign import ccall safe "registerAlertableWait"--- (bool has_timeout, DWORD mssec);-  c_registerAlertableWait :: Bool -> DWORD  -> IO ()--foreign import ccall safe "getOverlappedEntries"-  getOverlappedEntries :: Ptr DWORD -> IO (Ptr OVERLAPPED_ENTRY)--foreign import ccall safe "completeSynchronousRequest"-  completeSynchronousRequest :: IO ()----------------------------------------------------------------------------- Manager structures---- | Pointer offset in bytes to the location of hoData in HASKELL_OVERLAPPPED-cdOffset :: Int-cdOffset = #{const __builtin_offsetof (HASKELL_OVERLAPPED, hoData)}---- | Terminator symbol for IOCP request-nullReq :: Ptr CompletionData-nullReq = castPtr $ unsafePerformIO $ new (0 :: Int)-{-# NOINLINE nullReq #-}---- I don't expect a lot of events, so a simple linked lists should be enough.-type EventElements = [(Event, HandleData)]-data EventData = EventData { evtTopLevel :: !Event, evtElems :: !EventElements }--instance Monoid EventData where-  mempty  = EventData evtNothing []-  mappend = (<>)--instance Semigroup EventData where-  (<>)   = \a b -> EventData (evtTopLevel a <> evtTopLevel b)-                             (evtElems a ++ evtElems b)-  stimes = stimesMonoid--data IOResult a-  = IOSuccess { ioValue :: a }-  | IOFailed  { ioErrCode :: Maybe Int }---- | The state object for the I/O manager.  This structure is available for both--- the threaded and the non-threaded RTS.-data Manager = Manager-    { mgrIOCP         :: {-# UNPACK #-} !FFI.IOCP-    , mgrClock        ::                !Clock-    , mgrUniqueSource :: {-# UNPACK #-} !UniqueSource-    , mgrTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)-    , mgrEvntHandlers :: {-# UNPACK #-}-                         !(MVar (IT.IntTable EventData))-    , mgrOverlappedEntries-                      :: {-#UNPACK #-} !(A.Array OVERLAPPED_ENTRY)-    , mgrThreadPool   :: Maybe ThreadPool-    }--{-# INLINE startIOManagerThread #-}--- | Starts a new I/O manager thread.--- For the threaded runtime it creates a pool of OS threads which stays alive--- until they are instructed to die.--- For the non-threaded runtime we have a single worker thread in--- the C runtime which we force to wake up instead.------ TODO: Threadpools are not yet implemented.-startIOManagerThread :: IO () -> IO ()-startIOManagerThread loop-  | not threadedIOMgr-  = debugIO "startIOManagerThread:NonThreaded" >>-    interruptSystemManager-  | otherwise = do-    modifyMVar_ ioManagerThread $ \old -> do-      let create = do debugIO "spawning worker threads.."-                      t <- forkOS loop-                      debugIO $ "created io-manager threads."-                      labelThread t "IOManagerThread"-                      return (Just t)-      debugIO $ "startIOManagerThread old=" ++ show old-      case old of-        Nothing -> create-        Just t  -> do-          s <- threadStatus t-          case s of-            ThreadFinished -> create-            ThreadDied     -> create-            _other         -> do  interruptSystemManager-                                  return (Just t)--requests :: MVar Word64-requests = unsafePerformIO $ newMVar 0--addRequest :: IO Word64-addRequest = modifyMVar requests (\x -> return (x + 1, x + 1))--removeRequest :: IO Word64-removeRequest = modifyMVar requests (\x -> return (x - 1, x - 1))--outstandingRequests :: IO Word64-outstandingRequests = withMVar requests return--getSystemManager :: IO Manager-getSystemManager = readMVar managerRef---- | Mutable reference to the IO manager-managerRef :: MVar Manager-managerRef = unsafePerformIO $ createManager >>= newMVar-  where-    -- | Create the I/O manager. In the Threaded I/O manager this call doesn't-    -- have any side effects, but in the Non-Threaded I/O manager the newly-    -- created IOCP handle will be registered with the RTS.  Users should never-    -- call this.-    -- It's only used to create the single global manager which is stored-    -- in an MVar.-    ---    -- NOTE: This needs to finish without making any calls to anything requiring the-    -- I/O manager otherwise we'll get into some weird synchronization issues.-    -- Essentially this means avoid using long running operations here.-    createManager :: IO Manager-    createManager = do-        debugIO "Starting io-manager..."-        mgrIOCP         <- FFI.newIOCP-        when (not threadedIOMgr) $-          registerIOCPHandle mgrIOCP-        debugIO $ "iocp: " ++ show mgrIOCP-        mgrClock             <- getClock-        mgrUniqueSource      <- newSource-        mgrTimeouts          <- newIORef Q.empty-        mgrOverlappedEntries <- A.new 64-        mgrEvntHandlers      <- newMVar =<< IT.new callbackArraySize-        let mgrThreadPool    = Nothing--        let !mgr = Manager{..}-        return mgr-{-# NOINLINE managerRef #-}---- | Interrupts an I/O manager Wait.  This will force the I/O manager to process--- any outstanding events and timers.  Also called when console events such as--- ctrl+c are used to break abort an I/O request.-interruptSystemManager :: IO ()-interruptSystemManager = do-  mgr <- getSystemManager-  debugIO "interrupt received.."-  FFI.postQueuedCompletionStatus (mgrIOCP mgr) 0 0 nullPtr---- | The initial number of I/O requests we can service at the same time.--- Must be power of 2.  This number is used as the starting point to scale--- the number of concurrent requests.  It will be doubled every time we are--- saturated.-callbackArraySize :: Int-callbackArraySize = 32---------------------------------------------------------------------------- Time utilities--secondsToNanoSeconds :: Seconds -> Q.Prio-secondsToNanoSeconds s = ceiling $ s * 1000000000--secondsToMilliSeconds :: Seconds -> Word32-secondsToMilliSeconds s = ceiling $ s * 1000--nanoSecondsToSeconds :: Q.Prio -> Seconds-nanoSecondsToSeconds n = fromIntegral n / 1000000000.0----------------------------------------------------------------------------- Overlapped I/O---- | Callback that starts the overlapped I/O operation.--- It must return successfully if and only if an I/O completion has been--- queued.  Otherwise, it must throw an exception, which 'withOverlapped'--- will rethrow.-type StartCallback a = LPOVERLAPPED -> IO a---- | Specialized callback type for I/O Completion Ports calls using--- withOverlapped.-type StartIOCallback a = StartCallback (CbResult a)---- | CallBack result type to disambiguate between the different states--- an I/O Completion call could be in.-data CbResult a-  = CbDone (Maybe DWORD) -- ^ Request was handled immediately, no queue.-  | CbPending            -- ^ Queued and to be handled by I/O manager-  | CbIncomplete         -- ^ I/O request is incomplete but not enqueued, handle-                         --   it synchronously.-  | CbError a            -- ^ I/O request abort, return failure immediately-  | CbNone Bool          -- ^ The caller did not do any checking, the I/O-                         --   manager will perform additional checks.-    deriving Show---- | Associate a 'HANDLE' with the current I/O manager's completion port.--- This must be done before using the handle with 'withOverlapped'.-associateHandle' :: HANDLE -> IO ()-associateHandle' hwnd-  = do mngr <- getSystemManager-       associateHandle mngr hwnd---- | A handle value representing an invalid handle.-invalidHandle :: HANDLE-invalidHandle = intPtrToPtr (#{const INVALID_HANDLE_VALUE})---- | Associate a 'HANDLE' with the I/O manager's completion port.  This must be--- done before using the handle with 'withOverlapped'.-associateHandle :: Manager -> HANDLE -> IO ()-associateHandle Manager{..} h =-    -- Don't try to if the handle is invalid.  This can happen with i.e a closed-    -- std handle.-    when (h /= invalidHandle) $-      -- Use as completion key the file handle itself, so we can track-      -- completion-      FFI.associateHandleWithIOCP mgrIOCP h (fromIntegral $ ptrToWordPtr h)---{- Note [Why use non-waiting getOverlappedResult requests.]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  When waiting for a request that is bound to be done soon-  we spin inside waitForCompletion. There are multiple reasons-  for this.--  In the non-threaded RTS we can't perform blocking calls to-  C functions without blocking the whole RTS so immediately-  a blocking call is not an option there.--  In the threaded RTS we don't use a blocking wait for different-  reasons. In particular performing a waiting request using-  getOverlappedResult uses the hEvent object embedded in the-  OVERLAPPED structure to wait for a signal.-  However we do not provide such an object as their creation-  would incur to much overhead. Making a waiting request a-  less useful operation as it doesn't guarantee that the-  operation we were waiting one finished. Only that some-  operation on the handle did.---}---- | Start an overlapped I/O operation, and wait for its completion.  If--- 'withOverlapped' is interrupted by an asynchronous exception, the operation--- will be canceled using @CancelIoEx@.------ 'withOverlapped' waits for a completion to arrive before returning or--- throwing an exception.  This means you can use functions like--- 'Foreign.Marshal.Alloc.alloca' to allocate buffers for the operation.-withOverlappedEx :: forall a.-                    Manager-                 -> String -- ^ Handle name-                 -> HANDLE -- ^ Windows handle associated with the operation.-                 -> Bool-                 -> Word64 -- ^ Value to use for the @OVERLAPPED@-                           --   structure's Offset/OffsetHigh members.-                 -> StartIOCallback Int-                 -> CompletionCallback (IOResult a)-                 -> IO (IOResult a)-withOverlappedEx mgr fname h async offset startCB completionCB = do-    signal <- newEmptyIOPort :: IO (IOPort (IOResult a))-    let signalReturn a = failIfFalse_ (dbgMsg "signalReturn") $-                            writeIOPort signal (IOSuccess a)-        signalThrow ex = failIfFalse_ (dbgMsg "signalThrow") $-                            writeIOPort signal (IOFailed ex)-    mask_ $ do-      let completionCB' e b = do-            result <- completionCB e b-            case result of-              IOSuccess val -> signalReturn val-              IOFailed  err -> signalThrow err--      -- Note [Memory Management]-      -- These callback data and especially the overlapped structs have to keep-      -- alive throughout the entire lifetime of the requests.   Since this-      -- function will block until done so it can call completionCB at the end-      -- we can safely use dynamic memory management here and so reduce the-      -- possibility of memory errors.-      withRequest async offset h completionCB' $ \hs_lpol cdData -> do-        let ptr_lpol = hs_lpol `plusPtr` cdOffset-        let lpol = castPtr hs_lpol-        -- We need to add the payload before calling startCBResult, the reason being-        -- that the I/O routine begins immediately then.  If we don't then the request-        -- may end up lost as processCompletion will get called with a null payload.-        poke ptr_lpol cdData--        -- Since FILE_SKIP_COMPLETION_PORT_ON_SUCCESS can't be-        -- relied on for non-file handles we need a way to prevent-        -- us from handling a request inline and handle a completion-        -- event handled without a queued I/O operation.  Which means we-        -- can't solely rely on the number of outstanding requests but most-        -- also check intermediate status.-        reqs <- addRequest-        debugIO $ "+1.. " ++ show reqs ++ " requests queued. | " ++ show lpol-        cdDataCheck <- peek ptr_lpol :: IO (Ptr CompletionData)-        debugIO $ "hs_lpol:" ++ show hs_lpol-                ++ " cdData:" ++ show cdData-                ++ " ptr_lpol:" ++ show ptr_lpol-                ++ " *ptr_lpol:" ++ show cdDataCheck--        startCBResult <- startCB lpol `onException`-                        (CbError `fmap` Win32.getLastError) >>= \result -> do-          -- Check to see if the operation was completed on a-          -- non-overlapping handle or was completed immediately.-          -- e.g. stdio redirection or data in cache, FAST I/O.-          success <- FFI.overlappedIOStatus lpol-          err     <- getLastError-          -- Determine if the caller has done any checking.  If not then check-          -- to see if the request was completed synchronously.  We have to-          -- in order to prevent deadlocks since if it has completed-          -- synchronously we've requested to not have the completion queued.-          let result' =-                case result of-                  CbNone ret -- Start by checking some flags which indicates we-                             -- are done.-                             | success == #{const STATUS_SUCCESS}          -> CbDone Nothing-                             | success == #{const STATUS_END_OF_FILE}      -> CbDone Nothing-                             -- Buffer was too small.. not sure what to do, so I'll just-                             -- complete the read request-                             | err     == #{const ERROR_MORE_DATA}         -> CbDone Nothing-                             | err     == #{const ERROR_SUCCESS}           -> CbDone Nothing-                             | err     == #{const ERROR_IO_PENDING}        -> CbPending-                             | err     == #{const ERROR_IO_INCOMPLETE}     -> CbIncomplete-                             | err     == #{const ERROR_HANDLE_EOF}        -> CbDone Nothing-                             | err     == #{const ERROR_BROKEN_PIPE}       -> CbDone Nothing-                             | err     == #{const ERROR_NO_MORE_ITEMS}     -> CbDone Nothing-                             | err     == #{const ERROR_OPERATION_ABORTED} -> CbDone Nothing-                             -- This is currently mapping all non-complete requests we don't know-                             -- about as an error. I wonder if this isn't too strict..-                             | not ret                                     -> CbError $ fromIntegral err-                             -- We check success codes after checking error as-                             -- errors are much more indicative-                             | success == #{const STATUS_PENDING}          -> CbPending-                             -- If not just assume we can complete.  If we can't this will-                             -- hang because we don't know how to properly deal with it.-                             -- I don't know what the best default here is...-                             | otherwise                                   -> CbPending-                  _                                                        -> result-          case result' of-            CbNone    _ -> error "withOverlappedEx: CbNone shouldn't happen."-            CbIncomplete -> do-               debugIO $ "handling incomplete request synchronously " ++ show (h, lpol)-               res <- waitForCompletion h lpol-               debugIO $ "done blocking request 2: " ++ show (h, lpol) ++ " - " ++ show res-               return res-            CbPending   -> do-              -- Before we enqueue check see if operation finished in the-              -- mean time, since caller may not have done this.-              -- Normally we'd have to clear lpol with 0 before this call,-              -- however the statuses we're interested in would not get to here-              -- so we can save the memset call.-              finished <- FFI.getOverlappedResult h lpol (not async)-              lasterr <- getLastError-              debugIO $ "== " ++ show (finished)-              status <- FFI.overlappedIOStatus lpol-              debugIO $ "== >< " ++ show (status)-              -- This status indicated that we have finished early and so we-              -- won't have a request enqueued.  Handle it inline.-              let done_early = status == #{const STATUS_SUCCESS}-                               || status == #{const STATUS_END_OF_FILE}-                               || errorIsCompleted lasterr-              -- This status indicates that the request hasn't finished early,-              -- but it will finish shortly.  The I/O manager will not be-              -- enqueuing this either.  Also needs to be handled inline.-              -- Sadly named pipes will always return this error, so in practice-              -- we end up always handling them synchronously. There is no good-              -- documentation on this.-              let will_finish_sync = lasterr == #{const ERROR_IO_INCOMPLETE}--              debugIO $ "== >*< " ++ show (finished, done_early, will_finish_sync, h, lpol, lasterr)-              case (finished, done_early, will_finish_sync) of-                (Just _, _, _) -> do-                  debugIO "request handled immediately (o/b), not queued."-                  return $ CbDone finished-                -- Still pending-                (Nothing, _, _) -> do-                    -- If we should add back support to suspend the IO Manager thread-                    -- then we will need to make sure it's running at this point.-                    return result'-            CbError err' -> signalThrow (Just err') >> return result'-            CbDone  _   -> do-              debugIO "request handled immediately (o), not queued." >> return result'--        -- If an exception was received while waiting for IO to complete-        -- we try to cancel the request here.-        let cancel e = do-                        nerr <- getLastError-                        debugIO $ "## Exception occurred. Cancelling request... "-                        debugIO $ show (e :: SomeException) ++ " : " ++ show nerr-                        _ <- uninterruptibleMask_ $ FFI.cancelIoEx' h lpol-                        -- we need to wait for the cancellation before removing-                        -- the pointer.-                        debugIO $ "## Waiting for cancellation record... "-                        _ <- FFI.getOverlappedResult h lpol True-                        oldDataPtr <- I.exchangePtr ptr_lpol nullReq-                        when (oldDataPtr == cdData) $-                          do reqs1 <- removeRequest-                             debugIO $ "-1.. " ++ show reqs1 ++ " requests queued after error."-                             completionCB' (fromIntegral nerr) 0-                        when (not threadedIOMgr) $-                          do -- Run timeouts. This way if we canceled the last-                             -- IO Request and have no timer events waiting we-                             -- can go into an unbounded alertable wait.-                             delay <- runExpiredTimeouts mgr-                             registerAlertableWait delay-                        return $ IOFailed Nothing-        let runner = do debugIO $ (dbgMsg ":: waiting ") ++ " | "  ++ show lpol-                        res <- readIOPort signal `catch` cancel-                        debugIO $ dbgMsg ":: signaled "-                        case res of-                          IOFailed err -> FFI.throwWinErr fname (maybe 0 fromIntegral err)-                          _            -> return res--        -- Sometimes we shouldn't bother with the I/O manager as the call has-        -- failed or is done.-        case startCBResult of-          CbPending    -> runner-          CbDone rdata -> do-            oldDataPtr <- I.exchangePtr ptr_lpol nullReq-            if (oldDataPtr == cdData)-              then-                do reqs2 <- removeRequest-                   debugIO $ "-1.. " ++ show reqs2 ++ " requests queued."-                   debugIO $ dbgMsg $ ":: done " ++ show lpol ++ " - " ++ show rdata-                   bytes <- if isJust rdata-                               then return rdata-                               -- Make sure it's safe to free the OVERLAPPED buffer-                               else FFI.getOverlappedResult h lpol False-                   cdDataCheck2 <- peek ptr_lpol :: IO (Ptr CompletionData)-                   debugIO $ dbgMsg $ ":: exit *ptr_lpol: " ++ show cdDataCheck2-                   debugIO $ dbgMsg $ ":: done bytes: " ++ show bytes-                   case bytes of-                     Just res -> completionCB 0 res-                     Nothing  -> do err <- FFI.overlappedIOStatus lpol-                                    numBytes <- FFI.overlappedIONumBytes lpol-                                    -- TODO: Remap between STATUS_ and ERROR_ instead-                                    -- of re-interpret here. But for now, don't care.-                                    let err' = fromIntegral err-                                    debugIO $ dbgMsg $ ":: done callback: " ++ show err' ++ " - " ++ show numBytes-                                    completionCB err' (fromIntegral numBytes)-              else readIOPort signal-          CbError err  -> do-            reqs3 <- removeRequest-            debugIO $ "-1.. " ++ show reqs3 ++ " requests queued."-            let err' = fromIntegral err-            completionCB err' 0-          _            -> do-            error "unexpected case in `startCBResult'"-      where dbgMsg s = s ++ " (" ++ show h ++ ":" ++ show offset ++ ")"-            -- Wait for .25ms (threaded) and 1ms (non-threaded)-            -- Yields in the threaded case allowing other work.-            -- Blocks all haskell execution in the non-threaded case.-            -- We might want to reconsider the non-threaded handling-            -- at some point.-            doShortWait :: IO ()-            doShortWait-                | threadedIOMgr = do-                    -- Uses an inline definition of threadDelay to prevent an import-                    -- cycle.-                    let usecs = 250 -- 0.25ms-                    m <- newEmptyIOPort-                    reg <- registerTimeout mgr usecs $-                                writeIOPort m () >> return ()-                    readIOPort m `onException` unregisterTimeout mgr reg-                | otherwise = sleepBlock 1 -- 1 ms-            waitForCompletion :: HANDLE -> Ptr FFI.OVERLAPPED -> IO (CbResult Int)-            waitForCompletion fhndl lpol = do-              -- Wait for the request to finish as it was running before and-              -- The I/O manager won't enqueue it due to our optimizations to-              -- prevent context switches in such cases.-              -- In the non-threaded case we must use a non-waiting query here-              -- otherwise the RTS will lock up until we get a result back.-              -- In the threaded case it can be beneficial to spin on the haskell-              -- side versus-              -- See also Note [Why use non-waiting getOverlappedResult requests.]-              res <- FFI.getOverlappedResult fhndl lpol False-              status <- FFI.overlappedIOStatus lpol-              case res of-                Nothing | status == #{const STATUS_END_OF_FILE}-                        -> do-                              when (not threadedIOMgr) completeSynchronousRequest-                              return $ CbDone res-                        | otherwise ->-                  do lasterr <- getLastError-                     let done = errorIsCompleted lasterr-                     -- debugIO $ ":: loop - " ++ show lasterr ++ " :" ++ show done-                     -- We will complete quite soon, in the threaded RTS we-                     -- probably don't really want to wait for it while we could-                     -- have done something else.  In particular this is because-                     -- of sockets which make take slightly longer.-                     -- There's a trade-off.  Using the timer would allow it do-                     -- to continue running other Haskell threads, but also-                     -- means it may take longer to complete the wait.-                     unless done doShortWait-                     if done-                        then do when (not threadedIOMgr)-                                  completeSynchronousRequest-                                return $ CbDone Nothing-                        else waitForCompletion fhndl lpol-                Just _ -> do-                   when (not threadedIOMgr) completeSynchronousRequest-                   return $ CbDone res-            unless :: Bool -> IO () -> IO ()-            unless p a = if p then a else return ()---- Safe version of function of withOverlappedEx that assumes your handle is--- set up for asynchronous access.-withOverlapped :: String-               -> HANDLE-               -> Word64 -- ^ Value to use for the @OVERLAPPED@-                         --   structure's Offset/OffsetHigh members.-               -> StartIOCallback Int-               -> CompletionCallback (IOResult a)-               -> IO (IOResult a)-withOverlapped fname h offset startCB completionCB = do-  mngr <- getSystemManager-  withOverlappedEx mngr fname h True offset startCB completionCB----------------------------------------------------------------------------- Helper to check if an error code implies an operation has completed.--errorIsCompleted :: ErrCode -> Bool-errorIsCompleted lasterr =-       lasterr == #{const ERROR_HANDLE_EOF}-    || lasterr == #{const ERROR_SUCCESS}-    || lasterr == #{const ERROR_BROKEN_PIPE}-    || lasterr == #{const ERROR_NO_MORE_ITEMS}-    || lasterr == #{const ERROR_OPERATION_ABORTED}----------------------------------------------------------------------------- I/O Utilities---- | Process an IOResult and throw an exception back to the user if the action--- has failed, or return the result.-withException :: String -> IO (IOResult a) -> IO a-withException name fn- = do res <- fn-      case res of-       IOSuccess a         -> return a-       IOFailed (Just err) -> FFI.throwWinErr name $ fromIntegral err-       IOFailed Nothing    -> FFI.throwWinErr name 0---- | Signal that the I/O action was successful.-ioSuccess :: a -> IO (IOResult a)-ioSuccess = return . IOSuccess---- | Signal that the I/O action has failed with the given reason.-ioFailed :: Integral a => a -> IO (IOResult a)-ioFailed = return . IOFailed . Just . fromIntegral---- | Signal that the I/O action has failed with the given reason.--- Polymorphic in successful result type.-ioFailedAny :: Integral a => a -> IO (IOResult b)-ioFailedAny = return . IOFailed . Just . fromIntegral----------------------------------------------------------------------------- Timeouts---- | Convert uS(Int) to nS(Word64/Q.Prio) capping at maxBound-expirationTime :: Clock -> Int -> IO Q.Prio-expirationTime mgr us = do-    now <- getTime mgr :: IO Seconds -- Double-    let now_ns = ceiling $ now * 1000 * 1000 * 1000 :: Word64-    let expTime-          -- Currently we treat overflows by clamping to maxBound. If humanity-          -- still exists in 2500 CE we will ned to be a bit more careful here.-          -- See #15158.-          | (maxBound - now_ns) `quot` 1000 < fromIntegral us  = maxBound :: Q.Prio-          | otherwise                                          = now_ns + ns-          where ns = 1000 * fromIntegral us-    return expTime---- | Register an action to be performed in the given number of seconds.  The--- returned 'TimeoutKey' can be used to later un-register or update the timeout.--- The timeout is automatically unregistered when it fires.------ The 'TimeoutCallback' will not be called more than once.-{-# NOINLINE registerTimeout #-}-registerTimeout :: Manager -> Int -> TimeoutCallback -> IO TimeoutKey-registerTimeout mgr@Manager{..} uSrelTime cb = do-    key <- newUnique mgrUniqueSource-    if uSrelTime <= 0 then cb-    else do-      !expTime <- expirationTime mgrClock uSrelTime :: IO Q.Prio-      editTimeouts mgr (Q.unsafeInsertNew key expTime cb)-    return $ TK key---- | Update an active timeout to fire in the given number of seconds (from the--- time 'updateTimeout' is called), instead of when it was going to fire.--- This has no effect if the timeout has already fired.-updateTimeout :: Manager -> TimeoutKey -> Seconds -> IO ()-updateTimeout mgr (TK key) relTime = do-    now <- getTime (mgrClock mgr)-    let !expTime = secondsToNanoSeconds $ now + relTime-    -- Note: editTimeouts unconditionally wakes the IO Manager-    --       but that is not required if the new time is after-    --       the current time.-    editTimeouts mgr (Q.adjust (const expTime) key)---- | Unregister an active timeout.  This is a harmless no-op if the timeout is--- already unregistered or has already fired.------ Warning: the timeout callback may fire even after--- 'unregisterTimeout' completes.-unregisterTimeout :: Manager -> TimeoutKey -> IO ()-unregisterTimeout mgr (TK key) = do-    editTimeouts mgr (Q.delete key)---- | Modify an existing timeout.  This isn't thread safe and so if the time to--- elapse the timer was close it may fire anyway.-editTimeouts :: Manager -> TimeoutEdit -> IO ()-editTimeouts mgr g = do-  atomicModifyIORef' (mgrTimeouts mgr) $ \tq -> (g tq, ())-  interruptSystemManager----------------------------------------------------------------------------- I/O manager loop---- | Call all expired timeouts, and return how much time until the next--- | expiration.-runExpiredTimeouts :: Manager -> IO (Maybe Seconds)-runExpiredTimeouts Manager{..} = do-    now <- getTime mgrClock-    (expired, delay) <- atomicModifyIORef' mgrTimeouts (mkTimeout now)-    -- Execute timeout callbacks.-    mapM_ Q.value expired-    when (not threadedIOMgr && not (null expired))-      completeSynchronousRequest-    debugIO $ "expired calls: " ++ show (length expired)-    return delay-      where-        mkTimeout :: Seconds -> TimeoutQueue ->-                     (TimeoutQueue, ([Q.Elem TimeoutCallback], Maybe Seconds))-        mkTimeout now tq =-            let (tq', (expired, sec)) = mkTimeout' (secondsToNanoSeconds now) tq-            in (tq', (expired, fmap nanoSecondsToSeconds sec))-        mkTimeout' :: Q.Prio -> TimeoutQueue ->-                     (TimeoutQueue, ([Q.Elem TimeoutCallback], Maybe Q.Prio))-        mkTimeout' now tq =-           -- Remove timeouts with expiration <= now.-           let (expired, tq') = Q.atMost now tq in-           -- See how soon the next timeout expires.-           case Q.prio `fmap` Q.findMin tq' of-            Nothing ->-                (tq', (expired, Nothing))-            Just t ->-                -- This value will always be positive since the call-                -- to 'atMost' above removed any timeouts <= 'now'-                let !t' = t - now-                in (tq', (expired, Just t'))---- | Return the delay argument to pass to GetQueuedCompletionStatus.---   Return value is in ms-fromTimeout :: Maybe Seconds -> Word32-fromTimeout Nothing                 = 120000-fromTimeout (Just sec) | sec > 120  = 120000-                       | sec > 0    = ceiling (sec * 1000)-                       | otherwise  = 0---- | Perform one full evaluation step of the I/O manager's service loop.--- This means process timeouts and completed completions and calculate the time--- for the next timeout.------ The I/O manager is then notified of how long it should block again based on--- the queued I/O requests and timers.  If the I/O manager was given a command--- to block, shutdown or suspend than that request is honored at the end of the--- loop.------ This function can be safely executed multiple times in parallel and is only--- used by the threaded manager.-step :: Bool -> Manager -> IO (Bool, Maybe Seconds)-step maxDelay mgr@Manager{..} = do-    -- Determine how long to wait the next time we block in an alertable state.-    delay <- runExpiredTimeouts mgr-    let !timer = if maxDelay && delay == Nothing-                    then #{const INFINITE}-                    else fromTimeout delay-    debugIO $ "next timer: " ++ show timer -- todo: print as hex-    if isJust delay-        then debugIO $ "I/O manager waiting: delay=" ++ show delay-        else debugIO $ "I/O manager pausing: maxDelay=" ++ show maxDelay--    -- Inform the threadpool that a thread is now-    -- entering a kernel mode wait and thus is ready for new work.-    notifyWaiting mgrThreadPool--    -- To quote Matt Godbolts:-    -- There are some unusual edge cases you need to deal with. The-    -- GetQueuedCompletionStatus function blocks a thread until there's-    -- work for it to do. Based on the return value, the number of bytes-    -- and the overlapped structure, there’s a lot of possible "reasons"-    -- for the function to have returned. Deciphering all the possible-    -- cases:-    ---    -- -------------------------------------------------------------------------    -- Ret value | OVERLAPPED | # of bytes | Description-    -- -------------------------------------------------------------------------    -- zero      | NULL       | n/a        | Call to GetQueuedCompletionStatus-    --   failed, and no data was dequeued from the IO port. This usually-    --   indicates an error in the parameters to GetQueuedCompletionStatus.-    ---    -- zero      | non-NULL   | n/a        | Call to GetQueuedCompletionStatus-    --   failed, but data was read or written. The thread must deal with the-    --   data (possibly freeing any associated buffers), but there is an error-    --   condition on the underlying HANDLE. Usually seen when the other end of-    --   a network connection has been forcibly closed but there's still data in-    --   the send or receive queue.-    ---    -- non-zero  | NULL       | n/a        | This condition doesn't happen due-    --   to IO requests, but is useful to use in combination with-    --   PostQueuedCompletionStatus as a way of indicating to threads that they-    --   should terminate.-    ---    -- non-zero  | non-NULL   | zero       | End of file for a file HANDLE, or-    --   the connection has been gracefully closed (for network connections).-    --   The OVERLAPPED buffer has still been used; and must be deallocated if-    --   necessary.-    ---    -- non-zero  | non-NULL   | non-zero   | "num bytes" of data have been-    --    transferred into the block pointed by the OVERLAPPED structure. The-    --    direction of the transfer is dependant on the call made to the IO-    --    port, it's up to the user to remember if it was a read or a write-    --    (usually by stashing extra data in the OVERLAPPED structure). The-    --    thread must deallocate the structure as necessary.-    ---    -- The getQueuedCompletionStatusEx call will remove entries queued by the OS-    -- and returns the finished ones in mgrOverlappedEntries and the number of-    -- entries removed.-    n <- FFI.getQueuedCompletionStatusEx mgrIOCP mgrOverlappedEntries timer-    debugIO "WinIORunning"-    -- If threaded this call informs the threadpool manager that a thread is-    -- busy.  If all threads are busy and we have not reached the maximum amount-    -- of allowed threads then the threadpool manager will spawn a new thread to-    -- allow us to scale under load.-    notifyRunning mgrThreadPool-    processCompletion mgr n delay---- | Process the results at the end of an evaluation loop.  This function will--- read all the completions, unblock up all the Haskell threads, clean up the book--- keeping of the I/O manager.--- It returns whether there is outstanding work (request or timer) to be--- done and how long it expects to have to wait till it can take action again.------ Note that this method can do less work than there are entries in the--- completion table.  This is because some completion entries may have been--- created due to calls to interruptIOManager which will enqueue a faux--- completion.------ NOTE: In Threaded mode things get a bit complicated the operation may have--- been completed even before we even got around to put the request in the--- waiting callback table.  These events are handled by having a separate queue--- for orphaned callback instances that the calling thread is supposed to check--- before adding something to the work queue.------ Thread safety: This function atomically replaces outstanding events with--- a pointer to nullReq. This means it's safe (but potentially wastefull) to--- have two concurrent or parallel invocations on the same array.-processCompletion :: Manager -> Int -> Maybe Seconds -> IO (Bool, Maybe Seconds)-processCompletion Manager{..} n delay = do-    -- If some completions are done, we need to process them and call their-    -- callbacks.  We then remove the callbacks from the bookkeeping and resize-    -- the array if required.-    when (n > 0) $ do-      forM_ [0..(n-1)] $ \idx -> do-        oe <- A.unsafeRead mgrOverlappedEntries idx :: IO OVERLAPPED_ENTRY-        let lpol     = lpOverlapped oe-        when (lpol /= nullPtr) $ do-          let hs_lpol  = castPtr lpol :: Ptr FFI.HASKELL_OVERLAPPED-          let ptr_lpol = castPtr (hs_lpol `plusPtr` cdOffset) :: Ptr (Ptr CompletionData)-          cdDataCheck <- peek ptr_lpol-          oldDataPtr <- I.exchangePtr ptr_lpol nullReq :: IO (Ptr CompletionData)-          debugIO $ " $ checking " ++ show lpol-                    ++ " -en ptr_lpol: " ++ show ptr_lpol-                    ++ " offset: " ++ show cdOffset-                    ++ " cdData: " ++ show cdDataCheck-                    ++ " at idx " ++ show idx-          ptrd <- peek ptr_lpol-          debugIO $ ":: nullReq " ++ show nullReq-          debugIO $ ":: oldDataPtr " ++ show oldDataPtr-          debugIO $ ":: oldDataPtr (ptr)" ++ show ptrd-          -- A nullPtr indicates that we received a request which we shouldn't-          -- have. Essentially the field is 0 initialized and a nullPtr means-          -- it wasn't given a payload.-          -- A nullReq means that something else already handled the request,-          -- this can happen if for instance the request was cancelled.-          -- The former is an error while the latter is OK.  For now we treat-          -- them both as the same, but external tools such as API monitor are-          -- used to distinguish between the two when doing API tracing.-          when (oldDataPtr /= nullPtr && oldDataPtr /= castPtr nullReq) $-            do debugIO $ "exchanged: " ++ show oldDataPtr-               payload <- peek oldDataPtr :: IO CompletionData-               cb <- deRefStablePtr (cdCallback payload)-               reqs <- removeRequest-               debugIO $ "-1.. " ++ show reqs ++ " requests queued."-               status <- FFI.overlappedIOStatus (lpOverlapped oe)-               -- TODO: Remap between STATUS_ and ERROR_ instead-               -- of re-interpret here. But for now, don't care.-               let status' = fromIntegral status-               -- We no longer explicitly free the memory, this is because we-               -- now require the callback to free the memory since the-               -- callback allocated it.  This allows us to simplify memory-               -- management and reduce bugs.  See Note [Memory Management].-               let bytes = dwNumberOfBytesTransferred oe-               debugIO $ "?: status " ++ show status' ++ " - " ++ show bytes ++ " bytes return."-               cb status' bytes--      -- clear the array so we don't erroneously interpret the output, in-      -- certain circumstances like lockFileEx the code could return 1 entry-      -- removed but the file data not been filled in.-      -- TODO: Maybe not needed..-      A.clear mgrOverlappedEntries--      -- Check to see if we received the maximum amount of entries we could-      -- this likely indicates a high number of I/O requests have been queued.-      -- In which case we should process more at a time.-      cap <- A.capacity mgrOverlappedEntries-      when (cap == n) $ A.ensureCapacity mgrOverlappedEntries (2*cap)--    -- Keep running if we still have some work queued or-    -- if we have a pending delay.-    reqs <- outstandingRequests-    debugIO $ "outstanding requests: " ++ show reqs-    let more = reqs > 0-    debugIO $ "has more: " ++ show more ++ " - removed: " ++  show n-    return (more || (isJust delay && threadedIOMgr), delay)---- | Entry point for the non-threaded I/O manager to be able to process--- completed completions.  It is mostly a wrapper around processCompletion--- and invoked by the C thread via the scheduler.-processRemoteCompletion :: IO ()-processRemoteCompletion = do-#if defined(DEBUG) || defined(DEBUG_TRACE)-  tid <- myThreadId-  labelThread tid $ "IOManagerThread-PRC" ++ show tid-#endif-  alloca $ \ptr_n -> do-    debugIO "processRemoteCompletion :: start ()"-    -- First figure out how much work we have to do.-    entries <- getOverlappedEntries ptr_n-    n <- fromIntegral `fmap` peek ptr_n-    -- This call will unmarshal data from the C buffer but pointers inside of-    -- this have not been read yet.-    _ <- peekArray n entries-    mngr <- getSystemManager-    let arr = mgrOverlappedEntries mngr-    A.unsafeCopyFromBuffer arr entries n--    -- Process timeouts-    delay <- runExpiredTimeouts mngr :: IO (Maybe Seconds)--    -- Process available completions-    _ <- processCompletion mngr n delay--    -- Update and potentially wake up IO Manager-    -- This call will unblock the non-threaded I/O manager.  After this it is no-    -- longer safe to use `entries` nor `completed` as they can now be modified-    -- by the C thread.-    registerAlertableWait delay--    debugIO "processRemoteCompletion :: done ()"-    return ()--registerAlertableWait :: Maybe Seconds  -> IO ()-registerAlertableWait Nothing =-  c_registerAlertableWait False 0-registerAlertableWait (Just delay) =-  c_registerAlertableWait True (secondsToMilliSeconds delay)---- | Event loop for the Threaded I/O manager.  The one for the non-threaded--- I/O manager is in AsyncWinIO.c in the rts.-io_mngr_loop :: HANDLE -> Manager -> IO ()-io_mngr_loop _event _mgr-  | not threadedIOMgr-  = do  debugIO "io_mngr_loop:no-op:called in non-threaded case"-        return ()-io_mngr_loop _event mgr = go False-    where-      go maxDelay =-          do debugIO "io_mngr_loop:WinIORunning"-             -- Step will process IO events, or block if none are outstanding.-             (more, delay) <- step maxDelay mgr-             let !use_max_delay = not (isJust delay || more)-             debugIO "I/O manager stepping."-             event_id <- c_readIOManagerEvent-             exit <--               case event_id of-                 _ | event_id == io_MANAGER_WAKEUP -> return False-                 _ | event_id == io_MANAGER_DIE    -> c_ioManagerFinished >> return True-                 0 -> return False -- spurious wakeup-                 _ -> do debugIO $ "handling console event: " ++ show (event_id `shiftR` 1)-                         start_console_handler (event_id `shiftR` 1)-                         return False--             -- If we have no more work to do, or something from the outside-             -- told us to stop then we let the thread die and stop the I/O-             -- manager.  It will be woken up again when there is more to do.-             case () of-               _ | exit              -> debugIO "I/O manager shutting down."-               _ -> go use_max_delay---io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32-io_MANAGER_WAKEUP = #{const IO_MANAGER_WAKEUP}-io_MANAGER_DIE    = #{const IO_MANAGER_DIE}---- | Wake up a single thread from the I/O Manager's worker queue.  This will--- unblock a thread blocked in `processCompletion` and allows the I/O manager to--- react accordingly to changes in timers or to process console signals.--- No-op if the io-manager is already running.-wakeupIOManager :: IO ()-wakeupIOManager-  = do mngr <- getSystemManager-       -- We don't care about the event handle here, only that it exists.-       _event <- c_getIOManagerEvent-       debugIO "waking up I/O manager."-       startIOManagerThread (io_mngr_loop (error "IOManagerEvent used") mngr)---- | Returns the signaling event for the IO Manager.-foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)-  c_getIOManagerEvent :: IO HANDLE---- | Reads one IO Manager event. For WINIO we distinguish:--- * Shutdown events, sent from the RTS--- * Console events, sent from the default console handler.--- * Wakeup events, which are not used by WINIO and will be ignored-foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)-  c_readIOManagerEvent :: IO Word32--foreign import ccall unsafe "ioManagerFinished" -- in the RTS (ThrIOManager.c)-  c_ioManagerFinished :: IO ()--foreign import ccall unsafe "rtsSupportsBoundThreads" threadedIOMgr :: Bool---- | Sleep for n ms-foreign import WINDOWS_CCONV unsafe "Sleep" sleepBlock :: Int -> IO ()---- ------------------------------------------------------------------------------ I/O manager event notifications---data HandleData = HandleData {-      tokenKey        :: {-# UNPACK #-} !HandleKey-    , tokenEvents     :: {-# UNPACK #-} !EventLifetime-    , _handleCallback :: !EventCallback-    }---- | A file handle registration cookie.-data HandleKey = HandleKey {-      handleValue  :: {-# UNPACK #-} !HANDLE-    , handleUnique :: {-# UNPACK #-} !Unique-    } deriving ( Eq   -- ^ @since 4.4.0.0-               , Show -- ^ @since 4.4.0.0-               )---- | Callback invoked on I/O events.-type EventCallback = HandleKey -> Event -> IO ()--registerHandle :: Manager -> EventCallback -> HANDLE -> Event -> Lifetime-               -> IO HandleKey-registerHandle (Manager{..}) cb hwnd evs lt = do-  u <- newUnique mgrUniqueSource-  let reg   = HandleKey hwnd u-      hwnd' = fromIntegral $ ptrToIntPtr hwnd-      el    = I.eventLifetime evs lt-      !hwdd = HandleData reg el cb-      event = EventData evs [(evs, hwdd)]-  _ <- withMVar mgrEvntHandlers $ \evts -> do-          IT.insertWith mappend hwnd' event evts-  wakeupIOManager-  return reg--unregisterHandle :: Manager -> HandleKey -> IO ()-unregisterHandle (Manager{..}) key@HandleKey{..} = do-  withMVar mgrEvntHandlers $ \evts -> do-    let hwnd' = fromIntegral $ ptrToIntPtr handleValue-    val <- IT.lookup hwnd' evts-    case val of-      Nothing -> return ()-      Just (EventData evs lst) -> do-        let cmp (_, a) (_, b) = tokenKey a == tokenKey b-            key'    = (undefined, HandleData key undefined undefined)-            updated = deleteBy cmp key' lst-            new_lst = EventData evs updated-        _ <- IT.updateWith (\_ -> return new_lst) hwnd' evts-        return ()---- ------------------------------------------------------------------------------ debugging--#if defined(DEBUG)-c_DEBUG_DUMP :: IO Bool-c_DEBUG_DUMP = return True -- scheduler `fmap` getDebugFlags-#endif--debugIO :: String -> IO ()-#if defined(DEBUG_TRACE)-debugIO s = traceEventIO ( "winIO :: " ++ s)-#elif defined(DEBUG)-debugIO s-  = do debug <- c_DEBUG_DUMP-       if debug-          then do tid <- myThreadId-                  let pref = if threadedIOMgr then "\t" else ""-                  _   <- withCStringLen (pref ++ "winio: " ++ s ++ " (" ++-                                         showThreadId tid ++ ")\n") $-                         \(p, len) -> c_write 2 (castPtr p) (fromIntegral len)-                  return ()-          else do return ()-#else-debugIO _ = return ()-#endif---- dbxIO :: String -> IO ()--- dbxIO s = do tid <- myThreadId---              let pref = if threadedIOMgr then "\t" else ""---              _   <- withCStringLen (pref ++ "winio: " ++ s ++ " (" ++---                                    showThreadId tid ++ ")\n") $---                    \(p, len) -> c_write 2 (castPtr p) (fromIntegral len)---              return ()
− GHC/Event/Windows/Clock.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-module GHC.Event.Windows.Clock (-    Clock,-    Seconds,-    getTime,-    getClock,--    -- * Specific implementations-    queryPerformanceCounter,-    getTickCount64-) where--import qualified GHC.Event.Windows.FFI as FFI--import Data.Maybe-import GHC.Base-import GHC.Real---- | Monotonic clock-newtype Clock = Clock (IO Seconds)--type Seconds = Double---- | Get the current time, in seconds since some fixed time in the past.-getTime :: Clock -> IO Seconds-getTime (Clock io) = io---- | Figure out what time API to use, and return a 'Clock' for accessing it.-getClock :: IO Clock-getClock = tryInOrder-           [ queryPerformanceCounter-           , fmap Just getTickCount64-           ]--tryInOrder :: Monad m => [m (Maybe a)] -> m a-tryInOrder (x:xs) = x >>= maybe (tryInOrder xs) return-tryInOrder []     = undefined--mapJust :: Monad m => m (Maybe a) -> (a -> b) -> m (Maybe b)-mapJust m f = liftM (fmap f) m--queryPerformanceCounter :: IO (Maybe Clock)-queryPerformanceCounter =-    FFI.queryPerformanceFrequency `mapJust` \freq ->-    Clock $! do-        count <- FFI.queryPerformanceCounter-        let !secs = fromIntegral count / fromIntegral freq-        return secs--getTickCount64 :: IO Clock-getTickCount64 =-    return $! Clock $! do-      msecs <- FFI.getTickCount64-      return $! fromIntegral msecs / 1000
− GHC/Event/Windows/ConsoleEvent.hsc 
@@ -1,72 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Event.Windows.ConsoleEvent--- 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)------ Windows I/O manager interfaces. Depending on which I/O Subsystem is used--- requests will be routed to different places.-----------------------------------------------------------------------------------module GHC.Event.Windows.ConsoleEvent (-  ConsoleEvent (..),-  start_console_handler,-  toWin32ConsoleEvent,-  win32ConsoleHandler-) where--import GHC.Base-import GHC.Conc.Sync-import GHC.Enum (Enum)-import GHC.IO (unsafePerformIO)-import GHC.MVar-import GHC.Num (Num(..))-import GHC.Read (Read)-import GHC.Word (Word32)-import GHC.Show (Show)--#include <windows.h>--data ConsoleEvent-  = ControlC-  | Break-  | Close-  -- these are sent to Services only.-  | Logoff-  | Shutdown-    deriving ( Eq   -- ^ @since 4.3.0.0-             , Ord  -- ^ @since 4.3.0.0-             , Enum -- ^ @since 4.3.0.0-             , Show -- ^ @since 4.3.0.0-             , Read -- ^ @since 4.3.0.0-             )--start_console_handler :: Word32 -> IO ()-start_console_handler r =-  case toWin32ConsoleEvent r of-    Just x  -> withMVar win32ConsoleHandler $ \handler -> do-                 _ <- forkIO (handler x)-                 return ()-    Nothing -> return ()--toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent-toWin32ConsoleEvent ev =-  case ev of-    #{const CTRL_C_EVENT        } -> Just ControlC-    #{const CTRL_BREAK_EVENT    } -> Just Break-    #{const CTRL_CLOSE_EVENT    } -> Just Close-    #{const CTRL_LOGOFF_EVENT   } -> Just Logoff-    #{const CTRL_SHUTDOWN_EVENT } -> Just Shutdown-    _                             -> Nothing--win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())-win32ConsoleHandler =-  unsafePerformIO (newMVar (errorWithoutStackTrace "win32ConsoleHandler"))
− GHC/Event/Windows/FFI.hsc 
@@ -1,544 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}------------------------------------------------------------------------------------ |--- Module      :  GHC.Event.Windows.FFI--- Copyright   :  (c) Tamar Christina 2019--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ WinIO Windows API Foreign Function imports-------------------------------------------------------------------------------------module GHC.Event.Windows.FFI (-    -- * IOCP-    IOCP(..),-    CompletionKey,-    newIOCP,-    associateHandleWithIOCP,-    getQueuedCompletionStatusEx,-    postQueuedCompletionStatus,-    getOverlappedResult,--    -- * Completion Data-    CompletionData(..),-    CompletionCallback,-    withRequest,--    -- * Overlapped-    OVERLAPPED,-    LPOVERLAPPED,-    OVERLAPPED_ENTRY(..),-    LPOVERLAPPED_ENTRY,-    HASKELL_OVERLAPPED,-    LPHASKELL_OVERLAPPED,-    allocOverlapped,-    zeroOverlapped,-    pokeOffsetOverlapped,-    overlappedIOStatus,-    overlappedIONumBytes,--    -- * Cancel pending I/O-    cancelIoEx,-    cancelIoEx',--    -- * Monotonic time--    -- ** GetTickCount-    getTickCount64,--    -- ** QueryPerformanceCounter-    queryPerformanceCounter,-    queryPerformanceFrequency,--    -- ** Miscellaneous-    throwWinErr,-    setLastError-) where--#include <ntstatus.h>-#include <windows.h>-#include "winio_structs.h"--##include "windows_cconv.h"--import Data.Maybe-import Foreign-import GHC.Base-import GHC.Num ((*))-import GHC.Real (fromIntegral)-import GHC.Show-import GHC.Windows-import qualified GHC.Event.Array as A-import qualified GHC.Windows     as Win32-import GHC.IO.Handle.Internals (debugIO)----------------------------------------------------------------------------- IOCP---- | An I/O completion port.-newtype IOCP = IOCP HANDLE-    deriving (Eq, Ord, Show)--type CompletionKey = ULONG_PTR---- | This function has two distinct purposes depending on the value of--- The completion port handle:------  - When the IOCP port is NULL then the function creates a new I/O completion---    port.  See `newIOCP`.------  - When The port contains a valid handle then the given handle is---    associated with he given completion port handle.  Once associated it---    cannot be easily changed.  Associating a Handle with a Completion Port---    allows the I/O manager's worker threads to handle requests to the given---    handle.-foreign import WINDOWS_CCONV unsafe "windows.h CreateIoCompletionPort"-    c_CreateIoCompletionPort :: HANDLE -> IOCP -> ULONG_PTR -> DWORD-                             -> IO IOCP---- | Create a new I/O completion port.-newIOCP :: IO IOCP-newIOCP = failIf (== IOCP nullPtr) "newIOCP" $-          c_CreateIoCompletionPort iNVALID_HANDLE_VALUE (IOCP nullPtr) 0 0---- | Associate a HANDLE with an I/O completion port.-associateHandleWithIOCP :: IOCP -> HANDLE -> CompletionKey -> IO ()-associateHandleWithIOCP iocp handle completionKey =-    failIf_ (/= iocp) "associateHandleWithIOCP" $-        c_CreateIoCompletionPort handle iocp completionKey 0--foreign import WINDOWS_CCONV safe "windows.h GetOverlappedResult"-    c_GetOverlappedResult :: HANDLE -> LPOVERLAPPED -> Ptr DWORD -> BOOL-                          -> IO BOOL---- | Get the result of a single overlap operation without the IO manager-getOverlappedResult :: HANDLE -> Ptr OVERLAPPED -> BOOL -> IO (Maybe DWORD)-getOverlappedResult handle lp block-  = alloca $ \bytes ->-        do res <- c_GetOverlappedResult handle lp bytes block-           if res-              then fmap Just $ peek bytes-              else return Nothing--foreign import WINDOWS_CCONV safe "windows.h GetQueuedCompletionStatusEx"-    c_GetQueuedCompletionStatusEx :: IOCP -> LPOVERLAPPED_ENTRY -> Word32-                                  -> Ptr ULONG -> DWORD -> BOOL -> IO BOOL---- | Note [Completion Ports]--- When an I/O operation has been queued by an operation--- (ReadFile/WriteFile/etc) it is placed in a queue that the driver uses when--- servicing IRQs.  This queue has some important properties:------ 1.) It is not an ordered queue.  Requests may be performed out of order as---     as the OS's native I/O manager may try to re-order requests such that as---     few random seeks as possible are needed to complete the pending---     operations.  As such do not assume a fixed order between something being---     queued and dequeued.------ 2.) Operations may skip the queue entirely.  In which case they do not end in---     in this function. (This is an optimization flag we have turned on. See---     `openFile`.)------ 3.) Across this call the specified OVERLAPPED_ENTRY buffer MUST remain live,---     and the buffer for an I/O operation cannot be freed or moved until---     `getOverlappedResult` says it's done.  The reason is the kernel may not---     have fully released the buffer, or finished writing to it when this---     operation returns.  Failure to adhere to this will cause your IRQs to be---     silently dropped and your program will never receive a completion for it.---     This means that the OVERLAPPED buffer must also remain valid for the---     duration of the call and as such must be allocated on the unmanaged heap.------ 4.) When a thread calls this method it is associated with the I/O manager's---     worker threads pool.  You should always use dedicated threads for this---     since the OS I/O manager will now monitor the threads.  If the thread---     becomes blocked for whatever reason, the Haskell I/O manager will wake up---     another threads from it's pool to service the remaining results.---     A new thread will also be woken up from the pool when the previous thread---     is busy servicing requests and new requests have finished.  For this---     reason the Haskell I/O manager multiplexes I/O operations from N haskell---     threads into 1 completion port, which is serviced by M native threads in---     an asynchronous method. This allows it to scale efficiently.-getQueuedCompletionStatusEx :: IOCP-                            -> A.Array OVERLAPPED_ENTRY-                            -> DWORD  -- ^ Timeout in milliseconds (or-                                      -- 'GHC.Windows.iNFINITE')-                            -> IO Int-getQueuedCompletionStatusEx iocp arr timeout =-    alloca $ \num_removed_ptr ->do-        A.unsafeLoad arr $ \oes cap -> do-            -- TODO: remove after debugging-            fillBytes oes 0 (cap * (sizeOf (undefined :: OVERLAPPED_ENTRY)))-            debugIO $ "-- call getQueuedCompletionStatusEx "-            -- don't block the call if the rts is not supporting threads.-            -- this would block the entire program.-            let alertable = False -- not rtsSupportsBoundThreads-            ok <- c_GetQueuedCompletionStatusEx iocp oes (fromIntegral cap)-                  num_removed_ptr timeout alertable-            debugIO $ "-- call getQueuedCompletionStatusEx: " ++ show ok-            err <- getLastError-            nc <- (peek num_removed_ptr)-            debugIO $ "-- getQueuedCompletionStatusEx: n=" ++ show nc ++ " ,err=" ++ show err-            if ok then fromIntegral `fmap` peek num_removed_ptr-            else do debugIO $ "failed getQueuedCompletionStatusEx: " ++ show err-                    if err == #{const WAIT_TIMEOUT} || alertable then return 0-                    else failWith "GetQueuedCompletionStatusEx" err--overlappedIOStatus :: LPOVERLAPPED -> IO NTSTATUS-overlappedIOStatus lpol = do-  status <- #{peek OVERLAPPED, Internal} lpol-  -- TODO: Map NTSTATUS to ErrCode?-  -- See https://github.com/libuv/libuv/blob/b12624c13693c4d29ca84b3556eadc9e9c0936a4/src/win/winsock.c#L153-  return status-{-# INLINE overlappedIOStatus #-}--overlappedIONumBytes :: LPOVERLAPPED -> IO ULONG_PTR-overlappedIONumBytes lpol = do-  bytes <- #{peek OVERLAPPED, InternalHigh} lpol-  return bytes-{-# INLINE overlappedIONumBytes #-}--foreign import WINDOWS_CCONV unsafe "windows.h PostQueuedCompletionStatus"-    c_PostQueuedCompletionStatus :: IOCP -> DWORD -> ULONG_PTR -> LPOVERLAPPED-                                 -> IO BOOL---- | Manually post a completion to the specified I/O port.  This will wake up--- a thread waiting `GetQueuedCompletionStatusEx`.-postQueuedCompletionStatus :: IOCP -> DWORD -> CompletionKey -> LPOVERLAPPED-                           -> IO ()-postQueuedCompletionStatus iocp numBytes completionKey lpol =-    failIfFalse_ "PostQueuedCompletionStatus" $-    c_PostQueuedCompletionStatus iocp numBytes completionKey lpol----------------------------------------------------------------------------- Completion Data---- | Called when the completion is delivered.-type CompletionCallback a = ErrCode   -- ^ 0 indicates success-                          -> DWORD     -- ^ Number of bytes transferred-                          -> IO a---- | Callback type that will be called when an I/O operation completes.-type IOCallback = CompletionCallback ()---- | Structure that the I/O manager uses to associate callbacks with--- additional payload such as their OVERLAPPED structure and Win32 handle--- etc.  *Must* be kept in sync with that in `winio_structs.h` or horrible things--- happen.------ We keep the handle around for the benefit of ghc-external libraries making--- use of the manager.-data CompletionData = CompletionData { cdHandle   :: !HANDLE-                                     , cdCallback :: !(StablePtr IOCallback)-                                     }--instance Storable CompletionData where-    sizeOf _    = #{size CompletionData}-    alignment _ = #{alignment CompletionData}--    peek ptr = do-      cdCallback <- #{peek CompletionData, cdCallback} ptr-      cdHandle   <- #{peek CompletionData, cdHandle} ptr-      let !cd = CompletionData{..}-      return cd--    poke ptr CompletionData{..} = do-      #{poke CompletionData, cdCallback} ptr cdCallback-      #{poke CompletionData, cdHandle} ptr cdHandle----------------------------------------------------------------------------- Overlapped---- | Tag type for @LPOVERLAPPED@.-data OVERLAPPED---- | Tag type for the extended version of @OVERLAPPED@ containg some book---   keeping information.-data HASKELL_OVERLAPPED---- | Identifies an I/O operation.  Used as the @LPOVERLAPPED@ parameter--- for overlapped I/O functions (e.g. @ReadFile@, @WSASend@).-type LPOVERLAPPED = Ptr OVERLAPPED---- | Pointer to the extended HASKELL_OVERLAPPED function.-type LPHASKELL_OVERLAPPED = Ptr HASKELL_OVERLAPPED---- | An array of these is passed to GetQueuedCompletionStatusEx as an output--- argument.-data OVERLAPPED_ENTRY = OVERLAPPED_ENTRY {-      lpCompletionKey            :: ULONG_PTR,-      lpOverlapped               :: LPOVERLAPPED,-      dwNumberOfBytesTransferred :: DWORD-    }--type LPOVERLAPPED_ENTRY = Ptr OVERLAPPED_ENTRY--instance Storable OVERLAPPED_ENTRY where-    sizeOf _    = #{size OVERLAPPED_ENTRY}-    alignment _ = #{alignment OVERLAPPED_ENTRY}--    peek ptr = do-      lpCompletionKey <- #{peek OVERLAPPED_ENTRY, lpCompletionKey} ptr-      lpOverlapped    <- #{peek OVERLAPPED_ENTRY, lpOverlapped} ptr-      dwNumberOfBytesTransferred <--          #{peek OVERLAPPED_ENTRY, dwNumberOfBytesTransferred} ptr-      let !oe = OVERLAPPED_ENTRY{..}-      return oe--    poke ptr OVERLAPPED_ENTRY{..} = do-      #{poke OVERLAPPED_ENTRY, lpCompletionKey} ptr lpCompletionKey-      #{poke OVERLAPPED_ENTRY, lpOverlapped} ptr lpOverlapped-      #{poke OVERLAPPED_ENTRY, dwNumberOfBytesTransferred}-        ptr dwNumberOfBytesTransferred---- | Allocate a new--- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms684342%28v=vs.85%29.aspx--- OVERLAPPED> structure on the unmanaged heap. This also zeros the memory to--- prevent the values inside the struct to be incorrectlt interpreted as data--- payload.------ We extend the overlapped structure with some extra book keeping information--- such that we don't have to do a lookup on the Haskell side.------ Future: We can gain some performance here by using a pool instead of calling---         malloc for each request. A simple block allocator would be very---         useful here, especially when we implement sockets support.-allocOverlapped :: Word64 -- ^ Offset/OffsetHigh-                -> IO (Ptr HASKELL_OVERLAPPED)-allocOverlapped offset = do-  lpol <- mallocBytes #{size HASKELL_OVERLAPPED}-  zeroOverlapped lpol-  pokeOffsetOverlapped (castPtr lpol) offset-  return lpol---- | Zero-fill an HASKELL_OVERLAPPED structure.-zeroOverlapped :: LPHASKELL_OVERLAPPED -> IO ()-zeroOverlapped lpol = fillBytes lpol 0 #{size HASKELL_OVERLAPPED}-{-# INLINE zeroOverlapped #-}---- | Set the offset field in an OVERLAPPED structure.-pokeOffsetOverlapped :: LPOVERLAPPED -> Word64 -> IO ()-pokeOffsetOverlapped lpol offset = do-  let (offsetHigh, offsetLow) = Win32.ddwordToDwords offset-  #{poke OVERLAPPED, Offset} lpol offsetLow-  #{poke OVERLAPPED, OffsetHigh} lpol offsetHigh-{-# INLINE pokeOffsetOverlapped #-}---- | Set the event field in an OVERLAPPED structure.-pokeEventOverlapped :: LPOVERLAPPED -> HANDLE -> IO ()-pokeEventOverlapped lpol event = do-  #{poke OVERLAPPED, hEvent} lpol event-{-# INLINE pokeEventOverlapped #-}----------------------------------------------------------------------------- Request management---- [Note AsyncHandles]--- In `winio` we have designed it to work in asynchronous mode always.--- According to the MSDN documentation[1][2], when a handle is not opened--- in asynchronous mode then the operation would simply work but operate--- synchronously.------ This seems to happen as documented for `File` handles, but `pipes` don't--- seem to follow this documented behavior and so are a problem.--- Under `msys2` your standard handles are actually pipes, not console--- handles or files.  As such running under an msys2 console causes a hang--- as the pipe read never returns.------ [1] https://docs.microsoft.com/en-us/windows/win32/fileio/synchronous-and-asynchronous-i-o--- [2] https://docs.microsoft.com/en-us/windows/win32/sync/synchronization-and-overlapped-input-and-output------ As such we need to annotate all NativeHandles with a Boolean to indicate--- wether it's an asynchronous handle or not.--- This allows us to manually wait for the completion instead of relying--- on the I/O system to do the right thing.  As we have been using the--- buffers in async mode we may not have moved the file pointer on the kernel--- object, as such we still need to give an `OVERLAPPED` structure, but we--- instead create an event object that we can wait on.------ As documented in MSDN this even object must be in manual reset mode.  This--- approach gives us the flexibility, with minimum impact to support both--- synchronous and asynchronous access.------ Additional approaches explored------ Normally the I/O system is in full control of all Handles it creates, with--- one big exception: inheritance.------ For any `HANDLE` we inherit we don't know how it's been open.  A different--- solution I have explored was to try to detect the `HANDLE` mode.--- But this approach would never work for a few reasons:------ 1. The presence of an asynchronous flag does not indicate that we are able---    to handle the operation asynchronously.  In particular, just because a---    `HANDLE` is open in async mode, it may not be associated with our---    completion port.--- 2. One can only associate a `HANDLE` to a *single* completion port.  As---    such, if the handle is opened in async mode but already registered to a---    completion port then we can't use it asynchronously.--- 3. You can only associate a completion port once, even if it's the same---    port.  This means were we to strap a `HANDLE` of it's `NativeHandle`---    wrapper and then wrap it again, we can't retest as the result would be---    invalid.  This is an issue because to pass `HANDLE`s we have to pass---    the native OS Handle not the Haskell one. i.e. remote-iserv.---- See [Note AsyncHandles]-withRequest :: Bool -> Word64 -> HANDLE -> IOCallback-            -> (Ptr HASKELL_OVERLAPPED -> Ptr CompletionData -> IO a)-            -> IO a-withRequest async offset hdl cb f = do-    -- Create the completion record and store it.-    -- We only need the record when we enqueue a request, however if we-    -- delay creating it then we will run into a race condition where the-    -- driver may have finished servicing the request before we were ready-    -- and so the request won't have the book keeping information to know-    -- what to do.  So because of that we always create the payload,  If we-    -- need it ok, if we don't that's no problem.  This approach prevents-    -- expensive lookups in hash-tables.-    ---    -- Todo: Use a memory pool for this so we don't have to hit malloc every-    --       time.  This would allow us to scale better.-    cb_sptr <- newStablePtr cb-    let cbData :: CompletionData-        cbData = CompletionData hdl cb_sptr-    r <- allocaBytes #{size HASKELL_OVERLAPPED} $ \hs_lpol ->-      with cbData $ \cdData -> do-        zeroOverlapped hs_lpol-        let lpol = castPtr hs_lpol-        pokeOffsetOverlapped lpol offset-        -- If doing a synchronous request then register an event object.-        -- This event object MUST be manual reset per MSDN.-        case async of-          True -> f hs_lpol cdData-          False -> do-            event <- failIfNull "withRequest (create)" $-                       c_CreateEvent nullPtr True False nullPtr-            debugIO $ "{{ event " ++ show event ++ " for " ++ show hs_lpol-            pokeEventOverlapped lpol event-            res <- f hs_lpol cdData-            -- Once the request has finished, close the object and free it.-            failIfFalse_ "withRequest (free)" $ c_CloseHandle event-            return res--    freeStablePtr cb_sptr-    return r----- | Create an event object for use when the HANDLE isn't asynchronous-foreign import WINDOWS_CCONV unsafe "windows.h CreateEventW"-    c_CreateEvent :: Ptr () -> Bool -> Bool -> LPCWSTR -> IO HANDLE---- | Close a handle object-foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"-    c_CloseHandle :: HANDLE -> IO Bool----------------------------------------------------------------------------- Cancel pending I/O---- | CancelIo shouldn't block, but cancellation happens infrequently,--- so we might as well be on the safe side.-foreign import WINDOWS_CCONV unsafe "windows.h CancelIoEx"-    c_CancelIoEx :: HANDLE -> LPOVERLAPPED -> IO BOOL---- | Cancel all pending overlapped I/O for the given file that was initiated by--- the current OS thread.  Cancelling is just a request for cancellation and--- before the OVERLAPPED struct is freed we must make sure that the IRQ has been--- removed from the queue.  See `getOverlappedResult`.-cancelIoEx :: HANDLE -> LPOVERLAPPED -> IO ()-cancelIoEx h o = failIfFalse_ "CancelIoEx" . c_CancelIoEx h $ o--cancelIoEx' :: HANDLE -> LPOVERLAPPED -> IO Bool-cancelIoEx' = c_CancelIoEx----------------------------------------------------------------------------- Monotonic time--foreign import WINDOWS_CCONV "windows.h GetTickCount64"-    c_GetTickCount64 :: IO #{type ULONGLONG}---- | Call the @GetTickCount64@ function, which returns a monotonic time in--- milliseconds.------ Problems:------  * Low resolution (10 to 16 milliseconds).------ <http://msdn.microsoft.com/en-us/library/windows/desktop/ms724408%28v=vs.85%29.aspx>-getTickCount64 :: IO Word64-getTickCount64 = c_GetTickCount64---- | Call the @QueryPerformanceCounter@ function.------ Problems:------  * Might not be available on some hardware.  Use 'queryPerformanceFrequency'---    to test for availability before calling this function.------  * On a multiprocessor computer, may produce different results on---    different processors due to hardware bugs.------ To get a monotonic time in seconds, divide the result of--- 'queryPerformanceCounter' by that of 'queryPerformanceFrequency'.------ <http://msdn.microsoft.com/en-us/library/windows/desktop/ms644904%28v=vs.85%29.aspx>-queryPerformanceCounter :: IO Int64-queryPerformanceCounter =-    callQP c_QueryPerformanceCounter-    >>= maybe (throwGetLastError "QueryPerformanceCounter") return---- | Call the @QueryPerformanceFrequency@ function.  Return 'Nothing' if the--- hardware does not provide a high-resolution performance counter.------ <http://msdn.microsoft.com/en-us/library/windows/desktop/ms644905%28v=vs.85%29.aspx>-queryPerformanceFrequency :: IO (Maybe Int64)-queryPerformanceFrequency = do-    m <- callQP c_QueryPerformanceFrequency-    case m of-        Nothing   -> return Nothing-        Just 0    -> return Nothing -- Shouldn't happen; just a safeguard to-                                    -- avoid a zero denominator.-        Just freq -> return (Just freq)--type QPFunc = Ptr Int64 -> IO BOOL--foreign import WINDOWS_CCONV "Windows.h QueryPerformanceCounter"-    c_QueryPerformanceCounter :: QPFunc--foreign import WINDOWS_CCONV "Windows.h QueryPerformanceFrequency"-    c_QueryPerformanceFrequency :: QPFunc--callQP :: QPFunc -> IO (Maybe Int64)-callQP qpfunc =-    allocaBytes #{size LARGE_INTEGER} $ \ptr -> do-        ok <- qpfunc ptr-        if ok then do-            n <- #{peek LARGE_INTEGER, QuadPart} ptr-            return (Just n)-        else-            return Nothing----------------------------------------------------------------------------- Miscellaneous--type ULONG_PTR  = #type ULONG_PTR--throwWinErr :: String -> ErrCode -> IO a-throwWinErr loc err = do-    c_SetLastError err-    Win32.failWith loc err--setLastError :: ErrCode -> IO ()-setLastError = c_SetLastError--foreign import WINDOWS_CCONV unsafe "windows.h SetLastError"-    c_SetLastError :: ErrCode -> IO ()
− GHC/Event/Windows/ManagedThreadPool.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RecordWildCards #-}------------------------------------------------------------------------------------ |--- Module      :  GHC.Event.Windows.ManagedThreadPool--- Copyright   :  (c) Tamar Christina 2019--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ WinIO Windows Managed Thread pool API.  This thread pool scales dynamically--- based on demand.-------------------------------------------------------------------------------------module GHC.Event.Windows.ManagedThreadPool-  ( ThreadPool(..)-  , startThreadPool-  , notifyRunning-  , notifyWaiting-  , monitorThreadPool-  ) where--import Control.Concurrent.MVar-import Data.Maybe-import Foreign-import GHC.Base-import GHC.Num ((-), (+))-import GHC.Real (fromIntegral)-import qualified GHC.Event.Array as A-import GHC.IO.Handle.Internals (debugIO)-import GHC.Conc.Sync (ThreadId(..))-import GHC.RTS.Flags----------------------------------------------------------------------------- Thread spool manager--type WorkerJob = IO ()---- | Thread pool manager state-data ThreadPool = ThreadPool-  { thrMainThread    :: Maybe ThreadId-  , thrMaxThreads    :: {-# UNPACK #-} !Int-  , thrMinThreads    :: {-# UNPACK #-} !Int-  , thrCurThreads    :: {-# UNPACK #-} !Int-  , thrCallBack      :: WorkerJob-  , thrActiveThreads :: MVar Int-  , thrMonitor       :: MVar ()-  , thrThreadIds     :: {-#UNPACK #-} !(A.Array ThreadId)-  }--startThreadPool :: WorkerJob -> IO ThreadPool-startThreadPool job = do-  debugIO "Starting I/O manager threadpool..."-  let thrMinThreads = 2-  let thrCurThreads = 0-  let thrCallBack   = job-  thrMaxThreads     <- (fromIntegral . numIoWorkerThreads) `fmap` getMiscFlags-  thrActiveThreads  <- newMVar 0-  thrMonitor        <- newEmptyMVar-  thrThreadIds      <- undefined -- A.new thrMaxThreads-  let thrMainThread = Nothing--  let !pool = ThreadPool{..}-  return pool--monitorThreadPool :: MVar () -> IO ()-monitorThreadPool monitor = do-  _active <- takeMVar monitor--  return ()--notifyRunning :: Maybe ThreadPool -> IO ()-notifyRunning Nothing     = return ()-notifyRunning (Just pool) = do-  modifyMVar_ (thrActiveThreads pool) (\x -> return $ x + 1)-  _ <- tryPutMVar (thrMonitor pool) ()-  return ()--notifyWaiting :: Maybe ThreadPool -> IO ()-notifyWaiting Nothing     = return ()-notifyWaiting (Just pool) = do-  modifyMVar_ (thrActiveThreads pool) (\x -> return $ x - 1)-  _ <- tryPutMVar (thrMonitor pool) ()-  return ()
− GHC/Event/Windows/Thread.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Event.Windows.Thread (-    ensureIOManagerIsRunning,-    interruptIOManager,-    threadDelay,-    registerDelay,-) where--import GHC.Conc.Sync-import GHC.Base-import GHC.Event.Windows-import GHC.IO-import GHC.IOPort--ensureIOManagerIsRunning :: IO ()-ensureIOManagerIsRunning = wakeupIOManager--interruptIOManager :: IO ()-interruptIOManager = interruptSystemManager--threadDelay :: Int -> IO ()-threadDelay usecs = mask_ $ do-    m <- newEmptyIOPort-    mgr <- getSystemManager-    reg <- registerTimeout mgr usecs $ writeIOPort m () >> return ()-    readIOPort m `onException` unregisterTimeout mgr reg--registerDelay :: Int -> IO (TVar Bool)-registerDelay usecs = do-    t <- newTVarIO False-    mgr <- getSystemManager-    _ <- registerTimeout mgr usecs $ atomically $ writeTVar t True-    return t-
− GHC/Exception.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , ExistentialQuantification-           , MagicHash-           , RecordWildCards-           , PatternSynonyms-  #-}-{-# LANGUAGE TypeInType #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Exception--- Copyright   :  (c) The University of Glasgow, 1998-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Exceptions and exception-handling functions.-----------------------------------------------------------------------------------module GHC.Exception-       ( module GHC.Exception.Type-       , throw-       , ErrorCall(..,ErrorCall)-       , errorCallException-       , errorCallWithCallStackException-         -- re-export CallStack and SrcLoc from GHC.Types-       , CallStack, fromCallSiteList, getCallStack, prettyCallStack-       , prettyCallStackLines, showCCSStack-       , SrcLoc(..), prettySrcLoc-       ) where--import GHC.Base-import GHC.Show-import GHC.Stack.Types-import GHC.OldList-import GHC.Prim-import GHC.IO.Unsafe-import {-# SOURCE #-} GHC.Stack.CCS-import GHC.Exception.Type---- | Throw an exception.  Exceptions may be thrown from purely--- functional code, but may only be caught within the 'IO' monad.-throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.-         Exception e => e -> a-throw e = raise# (toException e)---- | This is thrown when the user calls 'error'. The first @String@ is the--- argument given to 'error', second @String@ is the location.-data ErrorCall = ErrorCallWithLocation String String-    deriving ( Eq  -- ^ @since 4.7.0.0-             , Ord -- ^ @since 4.7.0.0-             )--pattern ErrorCall :: String -> ErrorCall-pattern ErrorCall err <- ErrorCallWithLocation err _ where-  ErrorCall err = ErrorCallWithLocation err ""--{-# COMPLETE ErrorCall #-}---- | @since 4.0.0.0-instance Exception ErrorCall---- | @since 4.0.0.0-instance Show ErrorCall where-  showsPrec _ (ErrorCallWithLocation err "") = showString err-  showsPrec _ (ErrorCallWithLocation err loc) =-      showString err . showChar '\n' . showString 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
− GHC/Exception.hs-boot 
@@ -1,38 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--{--This SOURCE-imported hs-boot module cuts a big dependency loop:--         GHC.Exception-imports  Data.Maybe-imports  GHC.Base-imports  GHC.Err-imports  {-# SOURCE #-} GHC.Exception--More dramatically--         GHC.Exception-imports  Data.Typeable-imports  Data.Typeable.Internal-imports  GHC.Arr (fingerprint representation etc)-imports  GHC.Real-imports  {-# SOURCE #-} GHC.Exception--However, GHC.Exceptions loop-breaking exports are all nice,-well-behaved, non-bottom values.  The clients use 'raise#'-to get a visibly-bottom value.--}--module GHC.Exception-  ( module GHC.Exception.Type-  , errorCallException-  , errorCallWithCallStackException-  ) where--import {-# SOURCE #-} GHC.Exception.Type-import GHC.Types ( Char )-import GHC.Stack.Types ( CallStack )--errorCallException :: [Char] -> SomeException-errorCallWithCallStackException :: [Char] -> CallStack -> SomeException
− GHC/Exception/Type.hs 
@@ -1,180 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Exception.Type--- Copyright   :  (c) The University of Glasgow, 1998-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Exceptions and exception-handling functions.-----------------------------------------------------------------------------------module GHC.Exception.Type-       ( Exception(..)    -- Class-       , SomeException(..), ArithException(..)-       , divZeroException, overflowException, ratioZeroDenomException-       , underflowException-       ) where--import Data.Maybe-import Data.Typeable (Typeable, cast)-   -- loop: Data.Typeable -> GHC.Err -> GHC.Exception-import GHC.Base-import GHC.Show--{- |-The @SomeException@ type is the root of the exception type hierarchy.-When an exception of type @e@ is thrown, behind the scenes it is-encapsulated in a @SomeException@.--}-data SomeException = forall e . Exception e => SomeException e---- | @since 3.0-instance Show SomeException where-    showsPrec p (SomeException e) = showsPrec p e--{- |-Any type that you wish to throw or catch as an exception must be an-instance of the @Exception@ class. The simplest case is a new exception-type directly below the root:--> data MyException = ThisException | ThatException->     deriving Show->-> instance Exception MyException--The default method definitions in the @Exception@ class do what we need-in this case. You can now throw and catch @ThisException@ and-@ThatException@ as exceptions:--@-*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException))-Caught ThisException-@--In more complicated examples, you may wish to define a whole hierarchy-of exceptions:--> ----------------------------------------------------------------------> -- Make the root exception type for all the exceptions in a compiler->-> data SomeCompilerException = forall e . Exception e => SomeCompilerException e->-> instance Show SomeCompilerException where->     show (SomeCompilerException e) = show e->-> instance Exception SomeCompilerException->-> compilerExceptionToException :: Exception e => e -> SomeException-> compilerExceptionToException = toException . SomeCompilerException->-> compilerExceptionFromException :: Exception e => SomeException -> Maybe e-> compilerExceptionFromException x = do->     SomeCompilerException a <- fromException x->     cast a->-> ----------------------------------------------------------------------> -- Make a subhierarchy for exceptions in the frontend of the compiler->-> data SomeFrontendException = forall e . Exception e => SomeFrontendException e->-> instance Show SomeFrontendException where->     show (SomeFrontendException e) = show e->-> instance Exception SomeFrontendException where->     toException = compilerExceptionToException->     fromException = compilerExceptionFromException->-> frontendExceptionToException :: Exception e => e -> SomeException-> frontendExceptionToException = toException . SomeFrontendException->-> frontendExceptionFromException :: Exception e => SomeException -> Maybe e-> frontendExceptionFromException x = do->     SomeFrontendException a <- fromException x->     cast a->-> ----------------------------------------------------------------------> -- Make an exception type for a particular frontend compiler exception->-> data MismatchedParentheses = MismatchedParentheses->     deriving Show->-> instance Exception MismatchedParentheses where->     toException   = frontendExceptionToException->     fromException = frontendExceptionFromException--We can now catch a @MismatchedParentheses@ exception as-@MismatchedParentheses@, @SomeFrontendException@ or-@SomeCompilerException@, but not other types, e.g. @IOException@:--@-*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses))-Caught MismatchedParentheses-*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException))-Caught MismatchedParentheses-*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException))-Caught MismatchedParentheses-*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException))-*** Exception: MismatchedParentheses-@---}-class (Typeable e, Show e) => Exception e where-    toException   :: e -> SomeException-    fromException :: SomeException -> Maybe e--    toException = SomeException-    fromException (SomeException e) = cast e--    -- | Render this exception value in a human-friendly manner.-    ---    -- Default implementation: @'show'@.-    ---    -- @since 4.8.0.0-    displayException :: e -> String-    displayException = show---- | @since 3.0-instance Exception SomeException where-    toException se = se-    fromException = Just-    displayException (SomeException e) = displayException e---- |Arithmetic exceptions.-data ArithException-  = Overflow-  | Underflow-  | LossOfPrecision-  | DivideByZero-  | Denormal-  | RatioZeroDenominator -- ^ @since 4.6.0.0-  deriving ( Eq  -- ^ @since 3.0-           , Ord -- ^ @since 3.0-           )--divZeroException, overflowException, ratioZeroDenomException, underflowException  :: SomeException-divZeroException        = toException DivideByZero-overflowException       = toException Overflow-ratioZeroDenomException = toException RatioZeroDenominator-underflowException      = toException Underflow---- | @since 4.0.0.0-instance Exception ArithException---- | @since 4.0.0.0-instance Show ArithException where-  showsPrec _ Overflow        = showString "arithmetic overflow"-  showsPrec _ Underflow       = showString "arithmetic underflow"-  showsPrec _ LossOfPrecision = showString "loss of precision"-  showsPrec _ DivideByZero    = showString "divide by zero"-  showsPrec _ Denormal        = showString "denormal"-  showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator"
− GHC/Exception/Type.hs-boot 
@@ -1,16 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Exception.Type-  ( SomeException-  , divZeroException-  , overflowException-  , ratioZeroDenomException-  , underflowException-  ) where--import GHC.Num.Integer ()   -- See Note [Depend on GHC.Num.Integer] in GHC.Base--data SomeException-divZeroException, overflowException,-  ratioZeroDenomException, underflowException :: SomeException
− GHC/ExecutionStack.hs 
@@ -1,50 +0,0 @@--------------------------------------------------------------------------------- |--- 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
− GHC/ExecutionStack/Internal.hsc 
@@ -1,238 +0,0 @@--------------------------------------------------------------------------------- |--- 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 address 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.--    Moreover, 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 $-            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 ")"
− GHC/Exts.hs 
@@ -1,339 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE DeriveDataTypeable #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Exts--- Copyright   :  (c) The University of Glasgow 2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ GHC Extensions: this is the Approved Way to get at GHC-specific extensions.------ Note: no other base module should import this module.--------------------------------------------------------------------------------module GHC.Exts-       (-        -- * Representations of some basic types-        Int(..),Word(..),Float(..),Double(..),-        Char(..),-        Ptr(..), FunPtr(..),--        -- * The maximum tuple size-        maxTupleSize,--        -- * Primitive operations-        FUN, -- See https://gitlab.haskell.org/ghc/ghc/issues/18302-        module GHC.Prim,-        module GHC.Prim.Ext,-        shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,-        isTrue#,-        Void#,  -- Previously exported by GHC.Prim--        -- * Compat wrapper-        atomicModifyMutVar#,--        -- * Resize functions-        ---        -- | Resizing arrays of boxed elements is currently handled in-        -- library space (rather than being a primop) since there is not-        -- an efficient way to grow arrays. However, resize operations-        -- may become primops in a future release of GHC.-        resizeSmallMutableArray#,--        -- * Fusion-        build, augment,--        -- * Overloaded string literals-        IsString(..),--        -- * CString-        unpackCString#,-        unpackAppendCString#,-        unpackFoldrCString#,-        unpackCStringUtf8#,-        unpackNBytes#,-        cstringLength#,--        -- * Debugging-        breakpoint, breakpointCond,--        -- * Ids with special behaviour-        inline, noinline, lazy, oneShot, considerAccessible, SPEC (..),--        -- * Running 'RealWorld' state thread-        runRW#,--        -- * Safe coercions-        ---        -- | These are available from the /Trustworthy/ module "Data.Coerce" as well-        ---        -- @since 4.7.0.0-        Data.Coerce.coerce, Data.Coerce.Coercible,--        -- * Very unsafe coercion-        unsafeCoerce#,--        -- * Equality-        type (~~),--        -- * Representation polymorphism-        GHC.Prim.TYPE, RuntimeRep(..), Levity(..),-        LiftedRep, UnliftedRep, UnliftedType,-        VecCount(..), VecElem(..),--        -- * Transform comprehensions-        Down(..), groupWith, sortWith, the,--        -- * Event logging-        traceEvent,--        -- * SpecConstr annotations-        SpecConstrAnnotation(..),--        -- * The call stack-        currentCallStack,--        -- * The Constraint kind-        Constraint,--        -- * The Any type-        Any,--        -- * Overloaded lists-        IsList(..)-       ) where--import GHC.Prim hiding ( coerce, TYPE )-import qualified GHC.Prim-import qualified GHC.Prim.Ext-import GHC.Base hiding ( coerce )-import GHC.Ptr-import GHC.Stack--import qualified Data.Coerce-import Data.String-import Data.OldList-import Data.Data-import Data.Ord-import Data.Version ( Version(..), makeVersion )-import qualified Debug.Trace-import Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export--import Control.Applicative (ZipList(..))---- XXX This should really be in Data.Tuple, where the definitions are-maxTupleSize :: Int-maxTupleSize = 64---- | 'the' ensures that all the elements of the list are identical--- and then returns that unique element-the :: Eq a => [a] -> a-the (x:xs)-  | all (x ==) xs = x-  | 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-sortWith :: Ord b => (a -> b) -> [a] -> [a]-sortWith f = sortBy (\x y -> compare (f x) (f y))---- | The 'groupWith' function uses the user supplied function which--- projects an element out of every list element in order to first sort the--- input list and then to form groups by equality on these projected elements-{-# INLINE groupWith #-}-groupWith :: Ord b => (a -> b) -> [a] -> [[a]]-groupWith f xs = build (\c n -> groupByFB c n (\x y -> f x == f y) (sortWith f xs))--{-# INLINE [0] groupByFB #-} -- See Note [Inline FB functions] in GHC.List-groupByFB :: ([a] -> lst -> lst) -> lst -> (a -> a -> Bool) -> [a] -> lst-groupByFB c n eq xs0 = groupByFBCore xs0-  where groupByFBCore [] = n-        groupByFBCore (x:xs) = c (x:ys) (groupByFBCore zs)-            where (ys, zs) = span (eq x) xs----- -------------------------------------------------------------------------------- tracing--traceEvent :: String -> IO ()-traceEvent = Debug.Trace.traceEventIO-{-# DEPRECATED traceEvent "Use 'Debug.Trace.traceEvent' or 'Debug.Trace.traceEventIO'" #-} -- deprecated in 7.4---{- **********************************************************************-*                                                                       *-*              SpecConstr annotation                                    *-*                                                                       *-********************************************************************** -}---- Annotating a type with NoSpecConstr will make SpecConstr--- not specialise for arguments of that type.---- This data type is defined here, rather than in the SpecConstr module--- itself, so that importing it doesn't force stupidly linking the--- entire ghc package at runtime--data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr-                deriving ( Data -- ^ @since 4.3.0.0-                         , Eq   -- ^ @since 4.3.0.0-                         )---{- **********************************************************************-*                                                                       *-*              The IsList class                                         *-*                                                                       *-********************************************************************** -}---- | The 'IsList' class and its methods are intended to be used in---   conjunction with the OverloadedLists extension.------ @since 4.7.0.0-class IsList l where-  -- | The 'Item' type function returns the type of items of the structure-  --   @l@.-  type Item l--  -- | The 'fromList' function constructs the structure @l@ from the given-  --   list of @Item l@-  fromList  :: [Item l] -> l--  -- | The 'fromListN' function takes the input list's length and potentially-  --   uses it to construct the structure @l@ more efficiently compared to-  --   'fromList'. If the given number does not equal to the input list's length-  --   the behaviour of 'fromListN' is not specified.-  ---  --   prop> fromListN (length xs) xs == fromList xs-  fromListN :: Int -> [Item l] -> l-  fromListN _ = fromList--  -- | The 'toList' function extracts a list of @Item l@ from the structure @l@.-  --   It should satisfy fromList . toList = id.-  toList :: l -> [Item l]---- | @since 4.7.0.0-instance IsList [a] where-  type (Item [a]) = a-  fromList = id-  toList = id---- | @since 4.15.0.0-instance IsList (ZipList a) where-  type Item (ZipList a) = a-  fromList = ZipList-  toList = getZipList---- | @since 4.9.0.0-instance IsList (NonEmpty a) where-  type Item (NonEmpty a) = a--  fromList (a:as) = a :| as-  fromList [] = errorWithoutStackTrace "NonEmpty.fromList: empty list"--  toList ~(a :| as) = a : as---- | @since 4.8.0.0-instance IsList Version where-  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---- | An implementation of the old @atomicModifyMutVar#@ primop in--- terms of the new 'atomicModifyMutVar2#' primop, for backwards--- compatibility. The type of this function is a bit bogus. It's--- best to think of it as having type------ @--- atomicModifyMutVar#---   :: MutVar# s a---   -> (a -> (a, b))---   -> State# s---   -> (# State# s, b #)--- @------ but there may be code that uses this with other two-field record--- types.-atomicModifyMutVar#-  :: MutVar# s a-  -> (a -> b)-  -> State# s-  -> (# State# s, c #)-atomicModifyMutVar# mv f s =-  case unsafeCoerce# (atomicModifyMutVar2# mv f s) of-    (# s', _, ~(_, res) #) -> (# s', res #)---- | Resize a mutable array to new specified size. The returned--- 'SmallMutableArray#' is either the original 'SmallMutableArray#'--- resized in-place or, if not possible, a newly allocated--- 'SmallMutableArray#' with the original content copied over.------ To avoid undefined behaviour, the original 'SmallMutableArray#' shall--- not be accessed anymore after a 'resizeSmallMutableArray#' has been--- performed. Moreover, no reference to the old one should be kept in order--- to allow garbage collection of the original 'SmallMutableArray#'  in--- case a new 'SmallMutableArray#' had to be allocated.------ @since 4.14.0.0-resizeSmallMutableArray#-  :: SmallMutableArray# s a -- ^ Array to resize-  -> Int# -- ^ New size of array-  -> a-     -- ^ Newly created slots initialized to this element.-     -- Only used when array is grown.-  -> State# s-  -> (# State# s, SmallMutableArray# s a #)-resizeSmallMutableArray# arr0 szNew a s0 =-  case getSizeofSmallMutableArray# arr0 s0 of-    (# s1, szOld #) -> if isTrue# (szNew <# szOld)-      then case shrinkSmallMutableArray# arr0 szNew s1 of-        s2 -> (# s2, arr0 #)-      else if isTrue# (szNew ># szOld)-        then case newSmallArray# szNew a s1 of-          (# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of-            s3 -> (# s3, arr1 #)-        else (# s1, arr0 #)---- | Semantically, @considerAccessible = True@. But it has special meaning--- to the pattern-match checker, which will never flag the clause in which--- 'considerAccessible' occurs as a guard as redundant or inaccessible.--- Example:------ > case (x, x) of--- >   (True,  True)  -> 1--- >   (False, False) -> 2--- >   (True,  False) -> 3 -- Warning: redundant------ The pattern-match checker will warn here that the third clause is redundant.--- It will stop doing so if the clause is adorned with 'considerAccessible':------ > case (x, x) of--- >   (True,  True)  -> 1--- >   (False, False) -> 2--- >   (True,  False) | considerAccessible -> 3 -- No warning------ Put 'considerAccessible' as the last statement of the guard to avoid get--- confusing results from the pattern-match checker, which takes \"consider--- accessible\" by word.-considerAccessible :: Bool-considerAccessible = True
− GHC/Fingerprint.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy       #-}---- ----------------------------------------------------------------------------------  (c) The University of Glasgow 2006------ Fingerprints for recompilation checking and ABI versioning, and--- implementing fast comparison of Typeable.------ ------------------------------------------------------------------------------module GHC.Fingerprint (-        Fingerprint(..), fingerprint0,-        fingerprintData,-        fingerprintString,-        fingerprintFingerprints,-        getFileHash-   ) where--import GHC.IO-import GHC.Base-import GHC.Num-import GHC.List-import GHC.Real-import GHC.Show-import Foreign-import Foreign.C-import System.IO--import GHC.Fingerprint.Type---- for SIZEOF_STRUCT_MD5CONTEXT:-#include "HsBaseConfig.h"---- XXX instance Storable Fingerprint--- defined in Foreign.Storable to avoid orphan instance--fingerprint0 :: Fingerprint-fingerprint0 = Fingerprint 0 0--fingerprintFingerprints :: [Fingerprint] -> Fingerprint-fingerprintFingerprints fs = unsafeDupablePerformIO $-  withArrayLen fs $ \len p ->-    fingerprintData (castPtr p) (len * sizeOf (head fs))--fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint-fingerprintData buf len =-  allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do-    c_MD5Init pctxt-    c_MD5Update pctxt buf (fromIntegral len)-    allocaBytes 16 $ \pdigest -> do-      c_MD5Final pdigest pctxt-      peek (castPtr pdigest :: Ptr Fingerprint)--fingerprintString :: String -> Fingerprint-fingerprintString str = unsafeDupablePerformIO $-  withArrayLen word8s $ \len p ->-     fingerprintData p len-    where word8s = concatMap f str-          f c = let w32 :: Word32-                    w32 = fromIntegral (ord c)-                in [fromIntegral (w32 `shiftR` 24),-                    fromIntegral (w32 `shiftR` 16),-                    fromIntegral (w32 `shiftR` 8),-                    fromIntegral w32]---- | Computes the hash of a given file.--- This function loops over the handle, running in constant memory.------ @since 4.7.0.0-getFileHash :: FilePath -> IO Fingerprint-getFileHash path = withBinaryFile path ReadMode $ \h ->-  allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do-    c_MD5Init pctxt--    processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size))--    allocaBytes 16 $ \pdigest -> do-      c_MD5Final pdigest pctxt-      peek (castPtr pdigest :: Ptr Fingerprint)--  where-    _BUFSIZE = 4096--    -- | Loop over _BUFSIZE sized chunks read from the handle,-    -- passing the callback a block of bytes and its size.-    processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO ()-    processChunks h f = allocaBytes _BUFSIZE $ \arrPtr ->--      let loop = do-            count <- hGetBuf h arrPtr _BUFSIZE-            eof <- hIsEOF h-            when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $-              "GHC.Fingerprint.getFileHash: only read " ++ show count ++ " bytes"--            f arrPtr count--            when (not eof) loop--      in loop--data MD5Context--foreign import ccall unsafe "__hsbase_MD5Init"-   c_MD5Init   :: Ptr MD5Context -> IO ()-foreign import ccall unsafe "__hsbase_MD5Update"-   c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()-foreign import ccall unsafe "__hsbase_MD5Final"-   c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()
− GHC/Fingerprint.hs-boot 
@@ -1,14 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Fingerprint (-        fingerprintString,-        fingerprintFingerprints-  ) where--import GHC.Base-import GHC.Fingerprint.Type--fingerprintFingerprints :: [Fingerprint] -> Fingerprint-fingerprintString :: String -> Fingerprint-
− GHC/Fingerprint/Type.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---- ----------------------------------------------------------------------------------  (c) The University of Glasgow 2006------ Fingerprints for recompilation checking and ABI versioning, and--- implementing fast comparison of Typeable.------ ------------------------------------------------------------------------------module GHC.Fingerprint.Type (Fingerprint(..)) where--import GHC.Base-import GHC.List (length, replicate)-import GHC.Num-import GHC.Show-import GHC.Word-import Numeric (showHex)---- Using 128-bit MD5 fingerprints for now.--data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64-  deriving ( Eq  -- ^ @since 4.4.0.0-           , Ord -- ^ @since 4.4.0.0-           )---- | @since 4.7.0.0-instance Show Fingerprint where-  show (Fingerprint w1 w2) = hex16 w1 ++ hex16 w2-    where-      -- | Formats a 64 bit number as 16 digits hex.-      hex16 :: Word64 -> String-      hex16 i = let hex = showHex i ""-                 in replicate (16 - length hex) '0' ++ hex
− GHC/Float.hs 
@@ -1,1509 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns-           , CPP-           , GHCForeignImportPrim-           , NoImplicitPrelude-           , MagicHash-           , UnboxedTuples-           , UnliftedFFITypes-  #-}-{-# LANGUAGE CApiFFI #-}--- We believe we could deorphan this module, by moving lots of things--- around, but we haven't got there yet:-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_HADDOCK not-home #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Float--- Copyright   :  (c) The University of Glasgow 1994-2002---                Portions obtained from hbc (c) Lennart Augusstson--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The types 'Float' and 'Double', the classes 'Floating' and 'RealFloat' and--- casting between Word32 and Float and Word64 and Double.-----------------------------------------------------------------------------------#include "ieee-flpt.h"-#include "MachDeps.h"--#if WORD_SIZE_IN_BITS == 32-# define WSHIFT 5-# define MMASK 31-#elif WORD_SIZE_IN_BITS == 64-# define WSHIFT 6-# define MMASK 63-#else-# error unsupported WORD_SIZE_IN_BITS-#endif---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 GHC.Base-import GHC.Bits-import GHC.List-import GHC.Enum-import GHC.Show-import GHC.Num-import GHC.Real-import GHC.Word-import GHC.Arr-import GHC.Float.RealFracMethods-import GHC.Float.ConversionUtils-import GHC.Num.BigNat--infixr 8  **---- $setup--- >>> import Prelude----------------------------------------------------------------------------- Standard numeric classes----------------------------------------------------------------------------- | Trigonometric and hyperbolic functions and related functions.------ The Haskell Report defines no laws for 'Floating'. However, @('+')@, @('*')@--- and 'exp' are customarily expected to define an exponential field and have--- the following properties:------ * @exp (a + b)@ = @exp a * exp b@--- * @exp (fromInteger 0)@ = @fromInteger 1@----class  (Fractional a) => Floating a  where-    pi                  :: a-    exp, log, sqrt      :: a -> a-    (**), logBase       :: a -> a -> a-    sin, cos, tan       :: a -> a-    asin, acos, atan    :: a -> a-    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 #-}-    {-# INLINE tan #-}-    {-# INLINE tanh #-}-    x ** y              =  exp (log x * y)-    logBase x y         =  log y / log x-    sqrt x              =  x ** 0.5-    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))---- | Default implementation for @'log1mexp'@ requiring @'Ord'@ to test--- against a threshold to decide which implementation variant to use.-log1mexpOrd :: (Ord a, Floating a) => a -> a-{-# INLINE log1mexpOrd #-}-log1mexpOrd a-    | a > -(log 2) = log (negate (expm1 a))-    | otherwise  = log1p (negate (exp a))---- | Efficient, machine-independent access to the components of a--- floating-point number.-class  (RealFrac a, Floating a) => RealFloat a  where-    -- | a constant function, returning the radix of the representation-    -- (often @2@)-    floatRadix          :: a -> Integer-    -- | a constant function, returning the number of digits of-    -- 'floatRadix' in the significand-    floatDigits         :: a -> Int-    -- | a constant function, returning the lowest and highest values-    -- the exponent may assume-    floatRange          :: a -> (Int,Int)-    -- | The function 'decodeFloat' applied to a real floating-point-    -- number returns the significand expressed as an 'Integer' and an-    -- appropriately scaled exponent (an 'Int').  If @'decodeFloat' x@-    -- yields @(m,n)@, then @x@ is equal in value to @m*b^^n@, where @b@-    -- is the floating-point radix, and furthermore, either @m@ and @n@-    -- are both zero or else @b^(d-1) <= 'abs' m < b^d@, where @d@ is-    -- the value of @'floatDigits' x@.-    -- In particular, @'decodeFloat' 0 = (0,0)@. If the type-    -- contains a negative zero, also @'decodeFloat' (-0.0) = (0,0)@.-    -- /The result of/ @'decodeFloat' x@ /is unspecified if either of/-    -- @'isNaN' x@ /or/ @'isInfinite' x@ /is/ 'True'.-    decodeFloat         :: a -> (Integer,Int)-    -- | 'encodeFloat' performs the inverse of 'decodeFloat' in the-    -- sense that for finite @x@ with the exception of @-0.0@,-    -- @'Prelude.uncurry' 'encodeFloat' ('decodeFloat' x) = x@.-    -- @'encodeFloat' m n@ is one of the two closest representable-    -- floating-point numbers to @m*b^^n@ (or @&#177;Infinity@ if overflow-    -- occurs); usually the closer, but if @m@ contains too many bits,-    -- the result may be rounded in the wrong direction.-    encodeFloat         :: Integer -> Int -> a-    -- | 'exponent' corresponds to the second component of 'decodeFloat'.-    -- @'exponent' 0 = 0@ and for finite nonzero @x@,-    -- @'exponent' x = snd ('decodeFloat' x) + 'floatDigits' x@.-    -- If @x@ is a finite floating-point number, it is equal in value to-    -- @'significand' x * b ^^ 'exponent' x@, where @b@ is the-    -- floating-point radix.-    -- The behaviour is unspecified on infinite or @NaN@ values.-    exponent            :: a -> Int-    -- | The first component of 'decodeFloat', scaled to lie in the open-    -- interval (@-1@,@1@), either @0.0@ or of absolute value @>= 1\/b@,-    -- where @b@ is the floating-point radix.-    -- The behaviour is unspecified on infinite or @NaN@ values.-    significand         :: a -> a-    -- | multiplies a floating-point number by an integer power of the radix-    scaleFloat          :: Int -> a -> a-    -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value-    isNaN               :: a -> Bool-    -- | 'True' if the argument is an IEEE infinity or negative infinity-    isInfinite          :: a -> Bool-    -- | 'True' if the argument is too small to be represented in-    -- normalized format-    isDenormalized      :: a -> Bool-    -- | 'True' if the argument is an IEEE negative zero-    isNegativeZero      :: a -> Bool-    -- | 'True' if the argument is an IEEE floating point number-    isIEEE              :: a -> Bool-    -- | a version of arctangent taking two real floating-point arguments.-    -- For real floating @x@ and @y@, @'atan2' y x@ computes the angle-    -- (from the positive x-axis) of the vector from the origin to the-    -- point @(x,y)@.  @'atan2' y x@ returns a value in the range [@-pi@,-    -- @pi@].  It follows the Common Lisp semantics for the origin when-    -- signed zeroes are supported.  @'atan2' y 1@, with @y@ in a type-    -- that is 'RealFloat', should return the same value as @'atan' y@.-    -- A default definition of 'atan2' is provided, but implementors-    -- can provide a more accurate implementation.-    atan2               :: a -> a -> a---    exponent x          =  if m == 0 then 0 else n + floatDigits x-                           where (m,n) = decodeFloat x--    significand x       =  encodeFloat m (negate (floatDigits x))-                           where (m,_) = decodeFloat x--    scaleFloat 0 x      =  x-    scaleFloat k x-      | isFix           =  x-      | otherwise       =  encodeFloat m (n + clamp b k)-                           where (m,n) = decodeFloat x-                                 (l,h) = floatRange x-                                 d     = floatDigits x-                                 b     = h - l + 4*d-                                 -- n+k may overflow, which would lead-                                 -- to wrong results, hence we clamp the-                                 -- scaling parameter.-                                 -- If n + k would be larger than h,-                                 -- n + clamp b k must be too, similar-                                 -- for smaller than l - d.-                                 -- Add a little extra to keep clear-                                 -- from the boundary cases.-                                 isFix = x == 0 || isNaN x || isInfinite x--    atan2 y x-      | x > 0            =  atan (y/x)-      | x == 0 && y > 0  =  pi/2-      | x <  0 && y > 0  =  pi + atan (y/x)-      |(x <= 0 && y < 0)            ||-       (x <  0 && isNegativeZero y) ||-       (isNegativeZero x && isNegativeZero y)-                         = -atan2 (-y) x-      | y == 0 && (x < 0 || isNegativeZero x)-                          =  pi    -- must be after the previous test on zero y-      | x==0 && y==0      =  y     -- must be after the other double zero tests-      | otherwise         =  x + y -- x or y is a NaN, return a NaN (via +)----------------------------------------------------------------------------- Float----------------------------------------------------------------------------- | @since 2.01--- Note that due to the presence of @NaN@, not all elements of 'Float' have an--- additive inverse.------ >>> 0/0 + (negate 0/0 :: Float)--- NaN------ Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't--- have an additive identity------ >>> 0 + (-0 :: Float)--- 0.0-instance Num Float where-    (+)         x y     =  plusFloat x y-    (-)         x y     =  minusFloat x y-    negate      x       =  negateFloat x-    (*)         x y     =  timesFloat x y-    abs         x       =  fabsFloat x-    signum x | x > 0     = 1-             | x < 0     = negateFloat 1-             | otherwise = x -- handles 0.0, (-0.0), and NaN--    {-# INLINE fromInteger #-}-    fromInteger i = F# (integerToFloat# i)---- | Convert an Integer to a Float#-integerToFloat# :: Integer -> Float#-{-# NOINLINE integerToFloat# #-}-integerToFloat# (IS i)   = int2Float# i-integerToFloat# i@(IP _) = case integerToBinaryFloat' i of-                             F# x -> x-integerToFloat# (IN bn)  = case integerToBinaryFloat' (IP bn) of-                             F# x -> negateFloat# x---- | Convert a Natural to a Float#-naturalToFloat# :: Natural -> Float#-{-# NOINLINE naturalToFloat# #-}-naturalToFloat# (NS w) = word2Float# w-naturalToFloat# (NB b) = case integerToBinaryFloat' (IP b) of-                           F# x -> x---- | @since 2.01-instance  Real Float  where-    toRational (F# x#)  =-        case decodeFloat_Int# x# of-          (# m#, e# #)-            | isTrue# (e# >=# 0#)                               ->-                    (IS m# `integerShiftL#` int2Word# e#) :% 1-            | isTrue# ((int2Word# m# `and#` 1##) `eqWord#` 0##) ->-                    case elimZerosInt# m# (negateInt# e#) of-                      (# n, d# #) -> n :% integerShiftL# 1 (int2Word# d#)-            | otherwise                                         ->-                    IS m# :% integerShiftL# 1 (int2Word# (negateInt# e#))---- | @since 2.01--- Note that due to the presence of @NaN@, not all elements of 'Float' have an--- multiplicative inverse.------ >>> 0/0 * (recip 0/0 :: Float)--- NaN-instance  Fractional Float  where-    (/) x y             =  divideFloat x y-    {-# INLINE fromRational #-}-    fromRational (n:%d) = rationalToFloat n d-    recip x             =  1.0 / x--rationalToFloat :: Integer -> Integer -> Float-{-# NOINLINE [1] rationalToFloat #-}-rationalToFloat n 0-    | n == 0        = 0/0-    | n < 0         = (-1)/0-    | otherwise     = 1/0-rationalToFloat n d-    | n == 0        = encodeFloat 0 0-    | n < 0         = -(fromRat'' minEx mantDigs (-n) d)-    | otherwise     = fromRat'' minEx mantDigs n d-      where-        minEx       = FLT_MIN_EXP-        mantDigs    = FLT_MANT_DIG---- RULES for Integer and Int-{-# RULES-"properFraction/Float->Integer"     properFraction = properFractionFloatInteger-"truncate/Float->Integer"           truncate = truncateFloatInteger-"floor/Float->Integer"              floor = floorFloatInteger-"ceiling/Float->Integer"            ceiling = ceilingFloatInteger-"round/Float->Integer"              round = roundFloatInteger-"properFraction/Float->Int"         properFraction = properFractionFloatInt-"truncate/Float->Int"               truncate = float2Int-"floor/Float->Int"                  floor = floorFloatInt-"ceiling/Float->Int"                ceiling = ceilingFloatInt-"round/Float->Int"                  round = roundFloatInt-  #-}--- | @since 2.01-instance  RealFrac Float  where--        -- ceiling, floor, and truncate are all small-    {-# INLINE [1] ceiling #-}-    {-# INLINE [1] floor #-}-    {-# INLINE [1] truncate #-}---- We assume that FLT_RADIX is 2 so that we can use more efficient code-#if FLT_RADIX != 2-#error FLT_RADIX must be 2-#endif-    properFraction (F# x#)-      = case decodeFloat_Int# x# of-        (# m#, n# #) ->-            let m = I# m#-                n = I# n#-            in-            if n >= 0-            then (fromIntegral m * (2 ^ n), 0.0)-            else let i = if m >= 0 then                m `shiftR` negate n-                                   else negate (negate m `shiftR` negate n)-                     f = m - (i `shiftL` negate n)-                 in (fromIntegral i, encodeFloat (fromIntegral f) n)--    truncate x  = case properFraction x of-                     (n,_) -> n--    round x     = case properFraction x of-                     (n,r) -> let-                                m         = if r < 0.0 then n - 1 else n + 1-                                half_down = abs r - 0.5-                              in-                              case (compare half_down 0.0) of-                                LT -> n-                                EQ -> if even n then n else m-                                GT -> m--    ceiling x   = case properFraction x of-                    (n,r) -> if r > 0.0 then n + 1 else n--    floor x     = case properFraction x of-                    (n,r) -> if r < 0.0 then n - 1 else n---- | @since 2.01-instance  Floating Float  where-    pi                  =  3.141592653589793238-    exp x               =  expFloat x-    log x               =  logFloat x-    sqrt x              =  sqrtFloat x-    sin x               =  sinFloat x-    cos x               =  cosFloat x-    tan x               =  tanFloat x-    asin x              =  asinFloat x-    acos x              =  acosFloat x-    atan x              =  atanFloat x-    sinh x              =  sinhFloat x-    cosh x              =  coshFloat x-    tanh x              =  tanhFloat x-    (**) x y            =  powerFloat x y-    logBase x y         =  log y / log x--    asinh x             =  asinhFloat x-    acosh x             =  acoshFloat x-    atanh x             =  atanhFloat x--    log1p = log1pFloat-    expm1 = expm1Float--    log1mexp x = log1mexpOrd x-    {-# INLINE log1mexp #-}-    log1pexp a-      | a <= 18   = log1pFloat (exp a)-      | a <= 100  = a + exp (negate a)-      | otherwise = a-    {-# INLINE log1pexp #-}---- | @since 2.01-instance  RealFloat Float  where-    floatRadix _        =  FLT_RADIX        -- from float.h-    floatDigits _       =  FLT_MANT_DIG     -- ditto-    floatRange _        =  (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto--    decodeFloat (F# f#) = case decodeFloat_Int# f# of-                          (# i, e #) -> (IS i, I# e)--    encodeFloat i (I# e) = F# (integerEncodeFloat# i e)--    exponent x          = case decodeFloat x of-                            (m,n) -> if m == 0 then 0 else n + floatDigits x--    significand x       = case decodeFloat x of-                            (m,_) -> encodeFloat m (negate (floatDigits x))--    scaleFloat 0 x      = x-    scaleFloat k x-      | isFix           = x-      | otherwise       = case decodeFloat x of-                            (m,n) -> encodeFloat m (n + clamp bf k)-                        where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG-                              isFix = x == 0 || isFloatFinite x == 0--    isNaN x          = 0 /= isFloatNaN x-    isInfinite x     = 0 /= isFloatInfinite x-    isDenormalized x = 0 /= isFloatDenormalized x-    isNegativeZero x = 0 /= isFloatNegativeZero x-    isIEEE _         = True---- | @since 2.01-instance  Show Float  where-    showsPrec   x = showSignedFloat showFloat x-    showList = showList__ (showsPrec 0)----------------------------------------------------------------------------- Double----------------------------------------------------------------------------- | @since 2.01--- Note that due to the presence of @NaN@, not all elements of 'Double' have an--- additive inverse.------ >>> 0/0 + (negate 0/0 :: Double)--- NaN------ Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't--- have an additive identity------ >>> 0 + (-0 :: Double)--- 0.0-instance  Num Double  where-    (+)         x y     =  plusDouble x y-    (-)         x y     =  minusDouble x y-    negate      x       =  negateDouble x-    (*)         x y     =  timesDouble x y-    abs         x       =  fabsDouble x-    signum x | x > 0     = 1-             | x < 0     = negateDouble 1-             | otherwise = x -- handles 0.0, (-0.0), and NaN---    {-# INLINE fromInteger #-}-    fromInteger i = D# (integerToDouble# i)---- | Convert an Integer to a Double#-integerToDouble# :: Integer -> Double#-{-# NOINLINE integerToDouble# #-}-integerToDouble# (IS i)   = int2Double# i-integerToDouble# i@(IP _) = case integerToBinaryFloat' i of-                              D# x -> x-integerToDouble# (IN bn)  = case integerToBinaryFloat' (IP bn) of-                              D# x -> negateDouble# x---- | Encode a Natural (mantissa) into a Double#-naturalToDouble# :: Natural -> Double#-{-# NOINLINE naturalToDouble# #-}-naturalToDouble# (NS w) = word2Double# w-naturalToDouble# (NB b) = case integerToBinaryFloat' (IP b) of-                            D# x -> x----- | @since 2.01-instance  Real Double  where-    toRational (D# x#)  =-        case integerDecodeDouble# x# of-          (# m, e# #)-            | isTrue# (e# >=# 0#)                                  ->-                integerShiftL# m (int2Word# e#) :% 1-            | isTrue# ((integerToWord# m `and#` 1##) `eqWord#` 0##) ->-                case elimZerosInteger m (negateInt# e#) of-                    (# n, d# #) ->  n :% integerShiftL# 1 (int2Word# d#)-            | otherwise                                            ->-                m :% integerShiftL# 1 (int2Word# (negateInt# e#))---- | @since 2.01--- Note that due to the presence of @NaN@, not all elements of 'Double' have an--- multiplicative inverse.------ >>> 0/0 * (recip 0/0 :: Double)--- NaN-instance  Fractional Double  where-    (/) x y             =  divideDouble x y-    {-# INLINE fromRational #-}-    fromRational (n:%d) = rationalToDouble n d-    recip x             =  1.0 / x--rationalToDouble :: Integer -> Integer -> Double-{-# NOINLINE [1] rationalToDouble #-}-rationalToDouble n 0-    | n == 0        = 0/0-    | n < 0         = (-1)/0-    | otherwise     = 1/0-rationalToDouble n d-    | n == 0        = encodeFloat 0 0-    | n < 0         = -(fromRat'' minEx mantDigs (-n) d)-    | otherwise     = fromRat'' minEx mantDigs n d-      where-        minEx       = DBL_MIN_EXP-        mantDigs    = DBL_MANT_DIG---- | @since 2.01-instance  Floating Double  where-    pi                  =  3.141592653589793238-    exp x               =  expDouble x-    log x               =  logDouble x-    sqrt x              =  sqrtDouble x-    sin  x              =  sinDouble x-    cos  x              =  cosDouble x-    tan  x              =  tanDouble x-    asin x              =  asinDouble x-    acos x              =  acosDouble x-    atan x              =  atanDouble x-    sinh x              =  sinhDouble x-    cosh x              =  coshDouble x-    tanh x              =  tanhDouble x-    (**) x y            =  powerDouble x y-    logBase x y         =  log y / log x--    asinh x             =  asinhDouble x-    acosh x             =  acoshDouble x-    atanh x             =  atanhDouble x--    log1p = log1pDouble-    expm1 = expm1Double--    log1mexp x = log1mexpOrd x-    {-# 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-"truncate/Double->Integer"          truncate = truncateDoubleInteger-"floor/Double->Integer"             floor = floorDoubleInteger-"ceiling/Double->Integer"           ceiling = ceilingDoubleInteger-"round/Double->Integer"             round = roundDoubleInteger-"properFraction/Double->Int"        properFraction = properFractionDoubleInt-"truncate/Double->Int"              truncate = double2Int-"floor/Double->Int"                 floor = floorDoubleInt-"ceiling/Double->Int"               ceiling = ceilingDoubleInt-"round/Double->Int"                 round = roundDoubleInt-  #-}--- | @since 2.01-instance  RealFrac Double  where--        -- ceiling, floor, and truncate are all small-    {-# INLINE [1] ceiling #-}-    {-# INLINE [1] floor #-}-    {-# INLINE [1] truncate #-}--    properFraction x-      = case (decodeFloat x)      of { (m,n) ->-        if n >= 0 then-            (fromInteger m * 2 ^ n, 0.0)-        else-            case (quotRem m (2^(negate n))) of { (w,r) ->-            (fromInteger w, encodeFloat r n)-            }-        }--    truncate x  = case properFraction x of-                     (n,_) -> n--    round x     = case properFraction x of-                     (n,r) -> let-                                m         = if r < 0.0 then n - 1 else n + 1-                                half_down = abs r - 0.5-                              in-                              case (compare half_down 0.0) of-                                LT -> n-                                EQ -> if even n then n else m-                                GT -> m--    ceiling x   = case properFraction x of-                    (n,r) -> if r > 0.0 then n + 1 else n--    floor x     = case properFraction x of-                    (n,r) -> if r < 0.0 then n - 1 else n---- | @since 2.01-instance  RealFloat Double  where-    floatRadix _        =  FLT_RADIX        -- from float.h-    floatDigits _       =  DBL_MANT_DIG     -- ditto-    floatRange _        =  (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto--    decodeFloat (D# x#)-      = case integerDecodeDouble# x#   of-          (# i, j #) -> (i, I# j)--    encodeFloat i (I# j) = D# (integerEncodeDouble# i j)--    exponent x          = case decodeFloat x of-                            (m,n) -> if m == 0 then 0 else n + floatDigits x--    significand x       = case decodeFloat x of-                            (m,_) -> encodeFloat m (negate (floatDigits x))--    scaleFloat 0 x      = x-    scaleFloat k x-      | isFix           = x-      | otherwise       = case decodeFloat x of-                            (m,n) -> encodeFloat m (n + clamp bd k)-                        where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG-                              isFix = x == 0 || isDoubleFinite x == 0--    isNaN x             = 0 /= isDoubleNaN x-    isInfinite x        = 0 /= isDoubleInfinite x-    isDenormalized x    = 0 /= isDoubleDenormalized x-    isNegativeZero x    = 0 /= isDoubleNegativeZero x-    isIEEE _            = True---- | @since 2.01-instance  Show Double  where-    showsPrec   x = showSignedFloat showFloat x-    showList = showList__ (showsPrec 0)------------------------------------------------------------------------------ Enum instances---------------------------------------------------------------------------{--The @Enum@ instances for Floats and Doubles are slightly unusual.-The @toEnum@ function truncates numbers to Int.  The definitions-of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic-series: [0,0.1 .. 1.0].  However, roundoff errors make these somewhat-dubious.  This example may have either 10 or 11 elements, depending on-how 0.1 is represented.--NOTE: The instances for Float and Double do not make use of the default-methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being-a `non-lossy' conversion to and from Ints. Instead we make use of the-1.2 default methods (back in the days when Enum had Ord as a superclass)-for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.)--}---- | @since 2.01-instance  Enum Float  where-    succ x         = x + 1-    pred x         = x - 1-    toEnum         = int2Float-    fromEnum       = fromInteger . truncate   -- may overflow-    enumFrom       = numericEnumFrom-    enumFromTo     = numericEnumFromTo-    enumFromThen   = numericEnumFromThen-    enumFromThenTo = numericEnumFromThenTo---- | @since 2.01-instance  Enum Double  where-    succ x         = x + 1-    pred x         = x - 1-    toEnum         =  int2Double-    fromEnum       =  fromInteger . truncate   -- may overflow-    enumFrom       =  numericEnumFrom-    enumFromTo     =  numericEnumFromTo-    enumFromThen   =  numericEnumFromThen-    enumFromThenTo =  numericEnumFromThenTo----------------------------------------------------------------------------- Printing floating point----------------------------------------------------------------------------- | Show a signed 'RealFloat' value to full precision--- using standard decimal notation for arguments whose absolute value lies--- between @0.1@ and @9,999,999@, and scientific notation otherwise.-showFloat :: (RealFloat a) => a -> ShowS-showFloat x  =  showString (formatRealFloat FFGeneric Nothing x)---- These are the format types.  This type is not exported.--data FFFormat = FFExponent | FFFixed | FFGeneric---- This is just a compatibility stub, as the "alt" argument formerly--- didn't exist.-formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String-formatRealFloat fmt decs x = formatRealFloatAlt fmt decs False x--formatRealFloatAlt :: (RealFloat a) => FFFormat -> Maybe Int -> Bool -> a-                 -> String-formatRealFloatAlt fmt decs alt x-   | isNaN x                   = "NaN"-   | isInfinite x              = if x < 0 then "-Infinity" else "Infinity"-   | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x))-   | otherwise                 = doFmt fmt (floatToDigits (toInteger base) x)- where-  base = 10--  doFmt format (is, e) =-    let ds = map intToDigit is in-    case format of-     FFGeneric ->-      doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)-            (is,e)-     FFExponent ->-      case decs of-       Nothing ->-        let show_e' = show (e-1) in-        case ds of-          "0"     -> "0.0e0"-          [d]     -> d : ".0e" ++ show_e'-          (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'-          []      -> errorWithoutStackTrace "formatRealFloat/doFmt/FFExponent: []"-       Just d | d <= 0 ->-        -- handle this case specifically since we need to omit the-        -- decimal point as well (#15115).-        -- Note that this handles negative precisions as well for consistency-        -- (see #15509).-        case is of-          [0] -> "0e0"-          _ ->-           let-             (ei,is') = roundTo base 1 is-             n:_ = map intToDigit (if ei > 0 then init is' else is')-           in n : 'e' : show (e-1+ei)-       Just dec ->-        let dec' = max dec 1 in-        case is of-         [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0"-         _ ->-          let-           (ei,is') = roundTo base (dec'+1) is-           (d:ds') = map intToDigit (if ei > 0 then init is' else is')-          in-          d:'.':ds' ++ 'e':show (e-1+ei)-     FFFixed ->-      let-       mk0 ls = case ls of { "" -> "0" ; _ -> ls}-      in-      case decs of-       Nothing-          | e <= 0    -> "0." ++ replicate (-e) '0' ++ ds-          | otherwise ->-             let-                f 0 s    rs  = mk0 (reverse s) ++ '.':mk0 rs-                f n s    ""  = f (n-1) ('0':s) ""-                f n s (r:rs) = f (n-1) (r:s) rs-             in-                f e "" ds-       Just dec ->-        let dec' = max dec 0 in-        if e >= 0 then-         let-          (ei,is') = roundTo base (dec' + e) is-          (ls,rs)  = splitAt (e+ei) (map intToDigit is')-         in-         mk0 ls ++ (if null rs && not alt then "" else '.':rs)-        else-         let-          (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)-          d:ds' = map intToDigit (if ei > 0 then is' else 0:is')-         in-         d : (if null ds' && not alt then "" else '.':ds')---roundTo :: Int -> Int -> [Int] -> (Int,[Int])-roundTo base d is =-  case f d True is of-    x@(0,_) -> x-    (1,xs)  -> (1, 1:xs)-    _       -> errorWithoutStackTrace "roundTo: bad Value"- where-  b2 = base `quot` 2--  f n _ []     = (0, replicate n 0)-  f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, [])   -- Round to even when at exactly half the base-               | otherwise = (if x >= b2 then 1 else 0, [])-  f n _ (i:xs)-     | i' == base = (1,0:ds)-     | otherwise  = (0,i':ds)-      where-       (c,ds) = f (n-1) (even i) xs-       i'     = c + i---- Based on "Printing Floating-Point Numbers Quickly and Accurately"--- by R.G. Burger and R.K. Dybvig in PLDI 96.--- This version uses a much slower logarithm estimator. It should be improved.---- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,--- and returns a list of digits and an exponent.--- In particular, if @x>=0@, and------ > floatToDigits base x = ([d1,d2,...,dn], e)------ then------      (1) @n >= 1@------      (2) @x = 0.d1d2...dn * (base**e)@------      (3) @0 <= di <= base-1@--floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)-floatToDigits _ 0 = ([0], 0)-floatToDigits base x =- let-  (f0, e0) = decodeFloat x-  (minExp0, _) = floatRange x-  p = floatDigits x-  b = floatRadix x-  minExp = minExp0 - p -- the real minimum exponent-  -- Haskell requires that f be adjusted so denormalized numbers-  -- will have an impossibly low exponent.  Adjust for this.-  (f, e) =-   let n = minExp - e0 in-   if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0)-  (r, s, mUp, mDn) =-   if e >= 0 then-    let be = expt b e in-    if f == expt b (p-1) then-      (f*be*b*2, 2*b, be*b, be)     -- according to Burger and Dybvig-    else-      (f*be*2, 2, be, be)-   else-    if e > minExp && f == expt b (p-1) then-      (f*b*2, expt b (-e+1)*2, b, 1)-    else-      (f*2, expt b (-e)*2, 1, 1)-  k :: Int-  k =-   let-    k0 :: Int-    k0 =-     if b == 2 && base == 10 then-        -- logBase 10 2 is very slightly larger than 8651/28738-        -- (about 5.3558e-10), so if log x >= 0, the approximation-        -- k1 is too small, hence we add one and need one fixup step less.-        -- If log x < 0, the approximation errs rather on the high side.-        -- That is usually more than compensated for by ignoring the-        -- fractional part of logBase 2 x, but when x is a power of 1/2-        -- or slightly larger and the exponent is a multiple of the-        -- denominator of the rational approximation to logBase 10 2,-        -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x,-        -- we get a leading zero-digit we don't want.-        -- With the approximation 3/10, this happened for-        -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above.-        -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x-        -- for IEEE-ish floating point types with exponent fields-        -- <= 17 bits and mantissae of several thousand bits, earlier-        -- convergents to logBase 10 2 would fail for long double.-        -- Using quot instead of div is a little faster and requires-        -- fewer fixup steps for negative lx.-        let lx = p - 1 + e0-            k1 = (lx * 8651) `quot` 28738-        in if lx >= 0 then k1 + 1 else k1-     else-        -- f :: Integer, log :: Float -> Float,-        --               ceiling :: Float -> Int-        ceiling ((log (fromInteger (f+1) :: Float) +-                 fromIntegral e * log (fromInteger b)) /-                   log (fromInteger base))---WAS:            fromInt e * log (fromInteger b))--    fixup n =-      if n >= 0 then-        if r + mUp <= expt base n * s then n else fixup (n+1)-      else-        if expt base (-n) * (r + mUp) <= s then n else fixup (n+1)-   in-   fixup k0--  gen ds rn sN mUpN mDnN =-   let-    (dn, rn') = (rn * base) `quotRem` sN-    mUpN' = mUpN * base-    mDnN' = mDnN * base-   in-   case (rn' < mDnN', rn' + mUpN' > sN) of-    (True,  False) -> dn : ds-    (False, True)  -> dn+1 : ds-    (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds-    (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'--  rds =-   if k >= 0 then-      gen [] r (s * expt base k) mUp mDn-   else-     let bk = expt base (-k) in-     gen [] (r * bk) s (mUp * bk) (mDn * bk)- in- (map fromIntegral (reverse rds), k)----------------------------------------------------------------------------- Converting from an Integer to a RealFloat---------------------------------------------------------------------------{-# SPECIALISE integerToBinaryFloat' :: Integer -> Float,-                                        Integer -> Double #-}--- | Converts a positive integer to a floating-point value.------ The value nearest to the argument will be returned.--- If there are two such values, the one with an even significand will--- be returned (i.e. IEEE roundTiesToEven).------ The argument must be strictly positive, and @floatRadix (undefined :: a)@ must be 2.-integerToBinaryFloat' :: RealFloat a => Integer -> a-integerToBinaryFloat' n = result-  where-    mantDigs = floatDigits result-    k = I# (word2Int# (integerLog2# n))-    result = if k < mantDigs then-               encodeFloat n 0-             else-               let !e@(I# e#) = k - mantDigs + 1-                   q = n `unsafeShiftR` e-                   n' = case roundingMode# n (e# -# 1#) of-                          0# -> q-                          1# -> if integerToInt q .&. 1 == 0 then-                                  q-                                else-                                  q + 1-                          _ {- 2# -} -> q + 1-               in encodeFloat n' e----------------------------------------------------------------------------- Converting from a Rational to a RealFloat---------------------------------------------------------------------------{--[In response to a request for documentation of how fromRational works,-Joe Fasel writes:] A quite reasonable request!  This code was added to-the Prelude just before the 1.2 release, when Lennart, working with an-early version of hbi, noticed that (read . show) was not the identity-for floating-point numbers.  (There was a one-bit error about half the-time.)  The original version of the conversion function was in fact-simply a floating-point divide, as you suggest above. The new version-is, I grant you, somewhat denser.--Unfortunately, Joe's code doesn't work!  Here's an example:--main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")--This program prints-        0.0000000000000000-instead of-        1.8217369128763981e-300--Here's Joe's code:--\begin{pseudocode}-fromRat :: (RealFloat a) => Rational -> a-fromRat x = x'-        where x' = f e----              If the exponent of the nearest floating-point number to x---              is e, then the significand is the integer nearest xb^(-e),---              where b is the floating-point radix.  We start with a good---              guess for e, and if it is correct, the exponent of the---              floating-point number we construct will again be e.  If---              not, one more iteration is needed.--              f e   = if e' == e then y else f e'-                      where y      = encodeFloat (round (x * (1 % b)^^e)) e-                            (_,e') = decodeFloat y-              b     = floatRadix x'----              We obtain a trial exponent by doing a floating-point---              division of x's numerator by its denominator.  The---              result of this division may not itself be the ultimate---              result, because of an accumulation of three rounding---              errors.--              (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'-                                        / fromInteger (denominator x))-\end{pseudocode}--Now, here's Lennart's code (which works):--}---- | Converts a 'Rational' value into any type in class 'RealFloat'.-{-# RULES-"fromRat/Float"     fromRat = (fromRational :: Rational -> Float)-"fromRat/Double"    fromRat = (fromRational :: Rational -> Double)-  #-}--{-# NOINLINE [1] fromRat #-}-fromRat :: (RealFloat a) => Rational -> a---- Deal with special cases first, delegating the real work to fromRat'-fromRat (n :% 0) | n > 0     =  1/0        -- +Infinity-                 | n < 0     = -1/0        -- -Infinity-                 | otherwise =  0/0        -- NaN--fromRat (n :% d) | n > 0     = fromRat' (n :% d)-                 | n < 0     = - fromRat' ((-n) :% d)-                 | otherwise = encodeFloat 0 0             -- Zero---- Conversion process:--- Scale the rational number by the RealFloat base until--- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).--- Then round the rational to an Integer and encode it with the exponent--- that we got from the scaling.--- To speed up the scaling process we compute the log2 of the number to get--- a first guess of the exponent.--fromRat' :: (RealFloat a) => Rational -> a--- Invariant: argument is strictly positive-fromRat' x = r-  where b = floatRadix r-        p = floatDigits r-        (minExp0, _) = floatRange r-        minExp = minExp0 - p            -- the real minimum exponent-        xMax   = toRational (expt b p)-        ln     = I# (word2Int# (integerLogBase# b (numerator x)))-        ld     = I# (word2Int# (integerLogBase# b (denominator x)))-        p0     = (ln - ld - p) `max` minExp-        -- if x = n/d and ln = integerLogBase b n, ld = integerLogBase b d,-        -- then b^(ln-ld-1) < x < b^(ln-ld+1)-        f = if p0 < 0 then 1 :% expt b (-p0) else expt b p0 :% 1-        x0 = x / f-        -- if ln - ld >= minExp0, then b^(p-1) < x0 < b^(p+1), so there's at most-        -- one scaling step needed, otherwise, x0 < b^p and no scaling is needed-        (x', p') = if x0 >= xMax then (x0 / toRational b, p0+1) else (x0, p0)-        r = encodeFloat (round x') p'---- Exponentiation with a cache for the most common numbers.-minExpt, maxExpt :: Int-minExpt = 0-maxExpt = 1100--expt :: Integer -> Int -> Integer-expt base n =-    if base == 2 && n >= minExpt && n <= maxExpt then-        expts!n-    else-        if base == 10 && n <= maxExpt10 then-            expts10!n-        else-            base^n--expts :: Array Int Integer-expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]--maxExpt10 :: Int-maxExpt10 = 324--expts10 :: Array Int Integer-expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]]--{--Unfortunately, the old conversion code was awfully slow due to-a) a slow integer logarithm-b) repeated calculation of gcd's--For the case of Rational's coming from a Float or Double via toRational,-we can exploit the fact that the denominator is a power of two, which for-these brings a huge speedup since we need only shift and add instead-of division.--The below is an adaption of fromRat' for the conversion to-Float or Double exploiting the known floatRadix and avoiding-divisions as much as possible.--}--{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float,-                            Int -> Int -> Integer -> Integer -> Double #-}-fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a--- Invariant: n and d strictly positive-fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =-    case integerIsPowerOf2# d of-      (# | ldw# #) ->-          let ld# = word2Int# ldw#-          in case word2Int# (integerLog2# n) of-            ln# | isTrue# (ln# >=# (ld# +# me# -# 1#)) ->-                  -- this means n/d >= 2^(minEx-1), i.e. we are guaranteed to get-                  -- a normalised number, round to mantDigs bits-                  if isTrue# (ln# <# md#)-                    then encodeFloat n (I# (negateInt# ld#))-                    else let n'  = n `shiftR` (I# (ln# +# 1# -# md#))-                             n'' = case roundingMode# n (ln# -# md#) of-                                    0# -> n'-                                    2# -> n' + 1-                                    _  -> case fromInteger n' .&. (1 :: Int) of-                                            0 -> n'-                                            _ -> n' + 1-                         in encodeFloat n'' (I# (ln# -# ld# +# 1# -# md#))-                | otherwise ->-                  -- n/d < 2^(minEx-1), a denorm or rounded to 2^(minEx-1)-                  -- the exponent for encoding is always minEx-mantDigs-                  -- so we must shift right by (minEx-mantDigs) - (-ld)-                  case ld# +# (me# -# md#) of-                    ld'# | isTrue# (ld'# <=# 0#) -> -- we would shift left, so we don't shift-                           encodeFloat n (I# ((me# -# md#) -# ld'#))-                         | isTrue# (ld'# <=# ln#) ->-                           let n' = n `shiftR` (I# ld'#)-                           in case roundingMode# n (ld'# -# 1#) of-                                0# -> encodeFloat n' (minEx - mantDigs)-                                1# -> if fromInteger n' .&. (1 :: Int) == 0-                                        then encodeFloat n' (minEx-mantDigs)-                                        else encodeFloat (n' + 1) (minEx-mantDigs)-                                _  -> encodeFloat (n' + 1) (minEx-mantDigs)-                         | isTrue# (ld'# ># (ln# +# 1#)) -> encodeFloat 0 0 -- result of shift < 0.5-                         | otherwise ->  -- first bit of n shifted to 0.5 place-                           case integerIsPowerOf2# n of-                            (#       |  _ #) -> encodeFloat 0 0  -- round to even-                            (# (# #) |    #) -> encodeFloat 1 (minEx - mantDigs)-      (# (# #) | #) ->-          let ln = I# (word2Int# (integerLog2# n))-              ld = I# (word2Int# (integerLog2# d))-              -- 2^(ln-ld-1) < n/d < 2^(ln-ld+1)-              p0 = max minEx (ln - ld)-              (n', d')-                | p0 < mantDigs = (n `shiftL` (mantDigs - p0), d)-                | p0 == mantDigs = (n, d)-                | otherwise     = (n, d `shiftL` (p0 - mantDigs))-              -- if ln-ld < minEx, then n'/d' < 2^mantDigs, else-              -- 2^(mantDigs-1) < n'/d' < 2^(mantDigs+1) and we-              -- may need one scaling step-              scale p a b-                | (b `shiftL` mantDigs) <= a = (p+1, a, b `shiftL` 1)-                | otherwise = (p, a, b)-              (p', n'', d'') = scale (p0-mantDigs) n' d'-              -- n''/d'' < 2^mantDigs and p' == minEx-mantDigs or n''/d'' >= 2^(mantDigs-1)-              rdq = case n'' `quotRem` d'' of-                     (q,r) -> case compare (r `shiftL` 1) d'' of-                                LT -> q-                                EQ -> if fromInteger q .&. (1 :: Int) == 0-                                        then q else q+1-                                GT -> q+1-          in  encodeFloat rdq p'---- Assumption: Integer and Int# are strictly positive, Int# is less--- than logBase 2 of Integer, otherwise havoc ensues.--- Used only for the numerator in fromRational when the denominator--- is a power of 2.--- The Int# argument is log2 n minus the number of bits in the mantissa--- of the target type, i.e. the index of the first non-integral bit in--- the quotient.------ 0# means round down (towards zero)--- 1# means we have a half-integer, round to even--- 2# means round up (away from zero)-roundingMode# :: Integer -> Int# -> Int#-roundingMode# (IS i#) t =-   let-      k = int2Word# i# `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##)-      c = uncheckedShiftL# 1## t-   in if isTrue# (c `gtWord#` k)-         then 0#-         else if isTrue# (c `ltWord#` k)-                 then 2#-                 else 1#--roundingMode# (IN bn) t = roundingMode# (IP bn) t -- dummy-roundingMode# (IP bn) t =-   let-      j = word2Int# (int2Word# t `and#` MMASK##) -- index of relevant bit in word-      k = uncheckedIShiftRA# t WSHIFT#           -- index of relevant word-      r = bigNatIndex# bn k `and#` ((uncheckedShiftL# 2## j) `minusWord#` 1##)-      c = uncheckedShiftL# 1## j-      test i = if isTrue# (i <# 0#)-                  then 1#-                  else case bigNatIndex# bn i of-                          0## -> test (i -# 1#)-                          _   -> 2#-   in if isTrue# (c `gtWord#` r)-         then 0#-         else if isTrue# (c `ltWord#` r)-                 then 2#-                 else test (k -# 1#)----------------------------------------------------------------------------- Floating point numeric primops----------------------------------------------------------------------------- Definitions of the boxed PrimOps; these will be--- used in the case of partial applications, etc.--plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float-plusFloat   (F# x) (F# y) = F# (plusFloat# x y)-minusFloat  (F# x) (F# y) = F# (minusFloat# x y)-timesFloat  (F# x) (F# y) = F# (timesFloat# x y)-divideFloat (F# x) (F# y) = F# (divideFloat# x y)--negateFloat :: Float -> Float-negateFloat (F# x)        = F# (negateFloat# x)--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)-ltFloat     (F# x) (F# y) = isTrue# (ltFloat# x y)-leFloat     (F# x) (F# y) = isTrue# (leFloat# x y)--expFloat, expm1Float :: Float -> Float-logFloat, log1pFloat, sqrtFloat, fabsFloat :: Float -> Float-sinFloat, cosFloat, tanFloat  :: Float -> Float-asinFloat, acosFloat, atanFloat  :: Float -> Float-sinhFloat, coshFloat, tanhFloat  :: Float -> Float-asinhFloat, acoshFloat, atanhFloat  :: Float -> Float-expFloat    (F# x) = F# (expFloat# x)-expm1Float  (F# x) = F# (expm1Float# x)-logFloat    (F# x) = F# (logFloat# x)-log1pFloat  (F# x) = F# (log1pFloat# x)-sqrtFloat   (F# x) = F# (sqrtFloat# x)-fabsFloat   (F# x) = F# (fabsFloat# x)-sinFloat    (F# x) = F# (sinFloat# x)-cosFloat    (F# x) = F# (cosFloat# x)-tanFloat    (F# x) = F# (tanFloat# x)-asinFloat   (F# x) = F# (asinFloat# x)-acosFloat   (F# x) = F# (acosFloat# x)-atanFloat   (F# x) = F# (atanFloat# x)-sinhFloat   (F# x) = F# (sinhFloat# x)-coshFloat   (F# x) = F# (coshFloat# x)-tanhFloat   (F# x) = F# (tanhFloat# x)-asinhFloat  (F# x) = F# (asinhFloat# x)-acoshFloat  (F# x) = F# (acoshFloat# x)-atanhFloat  (F# x) = F# (atanhFloat# x)--powerFloat :: Float -> Float -> Float-powerFloat  (F# x) (F# y) = F# (powerFloat# x y)---- definitions of the boxed PrimOps; these will be--- used in the case of partial applications, etc.--plusDouble, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double-plusDouble   (D# x) (D# y) = D# (x +## y)-minusDouble  (D# x) (D# y) = D# (x -## y)-timesDouble  (D# x) (D# y) = D# (x *## y)-divideDouble (D# x) (D# y) = D# (x /## y)--negateDouble :: Double -> Double-negateDouble (D# x)        = D# (negateDouble# x)--gtDouble, geDouble, leDouble, ltDouble :: Double -> Double -> Bool-gtDouble    (D# x) (D# y) = isTrue# (x >##  y)-geDouble    (D# x) (D# y) = isTrue# (x >=## y)-ltDouble    (D# x) (D# y) = isTrue# (x <##  y)-leDouble    (D# x) (D# y) = isTrue# (x <=## y)--double2Float :: Double -> Float-double2Float (D# x) = F# (double2Float# x)--float2Double :: Float -> Double-float2Double (F# x) = D# (float2Double# x)--expDouble, expm1Double :: Double -> Double-logDouble, log1pDouble, sqrtDouble, fabsDouble :: Double -> Double-sinDouble, cosDouble, tanDouble  :: Double -> Double-asinDouble, acosDouble, atanDouble  :: Double -> Double-sinhDouble, coshDouble, tanhDouble  :: Double -> Double-asinhDouble, acoshDouble, atanhDouble  :: Double -> Double-expDouble    (D# x) = D# (expDouble# x)-expm1Double  (D# x) = D# (expm1Double# x)-logDouble    (D# x) = D# (logDouble# x)-log1pDouble  (D# x) = D# (log1pDouble# x)-sqrtDouble   (D# x) = D# (sqrtDouble# x)-fabsDouble   (D# x) = D# (fabsDouble# x)-sinDouble    (D# x) = D# (sinDouble# x)-cosDouble    (D# x) = D# (cosDouble# x)-tanDouble    (D# x) = D# (tanDouble# x)-asinDouble   (D# x) = D# (asinDouble# x)-acosDouble   (D# x) = D# (acosDouble# x)-atanDouble   (D# x) = D# (atanDouble# x)-sinhDouble   (D# x) = D# (sinhDouble# x)-coshDouble   (D# x) = D# (coshDouble# x)-tanhDouble   (D# x) = D# (tanhDouble# x)-asinhDouble  (D# x) = D# (asinhDouble# x)-acoshDouble  (D# x) = D# (acoshDouble# x)-atanhDouble  (D# x) = D# (atanhDouble# x)--powerDouble :: Double -> Double -> Double-powerDouble  (D# x) (D# y) = D# (x **## y)--foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int-foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int-foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int-foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int-foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int--foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int-foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int-foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int-foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int-foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int----------------------------------------------------------------------------- Coercion rules---------------------------------------------------------------------------word2Double :: Word -> Double-word2Double (W# w) = D# (word2Double# w)--word2Float :: Word -> Float-word2Float (W# w) = F# (word2Float# w)--{-# RULES-"realToFrac/Float->Float"   realToFrac   = id :: Float -> Float-"realToFrac/Float->Double"  realToFrac   = float2Double-"realToFrac/Double->Float"  realToFrac   = double2Float-"realToFrac/Double->Double" realToFrac   = id :: Double -> Double-"realToFrac/Int->Double"    realToFrac   = int2Double   -- See Note [realToFrac int-to-float]-"realToFrac/Int->Float"     realToFrac   = int2Float    --      ..ditto-    #-}--{--Note [realToFrac int-to-float]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Don found that the RULES for realToFrac/Int->Double and similarly-Float made a huge difference to some stream-fusion programs.  Here's-an example--      import Data.Array.Vector--      n = 40000000--      main = do-            let c = replicateU n (2::Double)-                a = mapU realToFrac (enumFromToU 0 (n-1) ) :: UArr Double-            print (sumU (zipWithU (*) c a))--Without the RULE we get this loop body:--      case $wtoRational sc_sY4 of ww_aM7 { (# ww1_aM9, ww2_aMa #) ->-      case $wfromRat ww1_aM9 ww2_aMa of tpl_X1P { D# ipv_sW3 ->-      Main.$s$wfold-        (+# sc_sY4 1)-        (+# wild_X1i 1)-        (+## sc2_sY6 (*## 2.0 ipv_sW3))--And with the rule:--     Main.$s$wfold-        (+# sc_sXT 1)-        (+# wild_X1h 1)-        (+## sc2_sXV (*## 2.0 (int2Double# sc_sXT)))--The running time of the program goes from 120 seconds to 0.198 seconds-with the native backend, and 0.143 seconds with the C backend.--A few more details in #2251, and the patch message-"Add RULES for realToFrac from Int".--}---- Utils--showSignedFloat :: (RealFloat a)-  => (a -> ShowS)       -- ^ a function that can show unsigned values-  -> Int                -- ^ the precedence of the enclosing context-  -> a                  -- ^ the value to show-  -> ShowS-showSignedFloat showPos p x-   | x < 0 || isNegativeZero x-       = showParen (p > 6) (showChar '-' . showPos (-x))-   | otherwise = showPos x--{--We need to prevent over/underflow of the exponent in encodeFloat when-called from scaleFloat, hence we clamp the scaling parameter.-We must have a large enough range to cover the maximum difference of-exponents returned by decodeFloat.--}-clamp :: Int -> Int -> Int-clamp bd k = max (-bd) (min bd k)---{--Note [Casting from integral to floating point types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To implement something like `reinterpret_cast` from C++ to go from a-floating-point type to an integral type one might naively think that the-following should work:--      cast :: Float -> Word32-      cast (F# f#) = W32# (unsafeCoerce# f#)--Unfortunately that is not the case, because all the `unsafeCoerce#` does is tell-the compiler that the types have changed. When one does the above cast and-tries to operate on the resulting `Word32` the code generator will generate code-that performs an integer/word operation on a floating-point register, which-results in a compile error.--The correct way of implementing `reinterpret_cast` to implement a primpop, but-that requires a unique implementation for all supported archetectures. The next-best solution is to write the value from the source register to memory and then-read it from memory into the destination register and the best way to do that-is using CMM.--}---- | @'castWord32ToFloat' w@ does a bit-for-bit copy from an integral value--- to a floating-point value.------ @since 4.10.0.0--{-# INLINE castWord32ToFloat #-}-castWord32ToFloat :: Word32 -> Float-castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#)--foreign import prim "stg_word32ToFloatzh"-    stgWord32ToFloat :: Word32# -> Float#----- | @'castFloatToWord32' f@ does a bit-for-bit copy from a floating-point value--- to an integral value.------ @since 4.10.0.0--{-# INLINE castFloatToWord32 #-}-castFloatToWord32 :: Float -> Word32-castFloatToWord32 (F# f#) = W32# (stgFloatToWord32 f#)--foreign import prim "stg_floatToWord32zh"-    stgFloatToWord32 :: Float# -> Word32#------ | @'castWord64ToDouble' w@ does a bit-for-bit copy from an integral value--- to a floating-point value.------ @since 4.10.0.0--{-# INLINE castWord64ToDouble #-}-castWord64ToDouble :: Word64 -> Double-castWord64ToDouble (W64# w) = D# (stgWord64ToDouble w)--foreign import prim "stg_word64ToDoublezh"-#if WORD_SIZE_IN_BITS == 64-    stgWord64ToDouble :: Word# -> Double#-#else-    stgWord64ToDouble :: Word64# -> Double#-#endif----- | @'castFloatToWord64' f@ does a bit-for-bit copy from a floating-point value--- to an integral value.------ @since 4.10.0.0--{-# INLINE castDoubleToWord64 #-}-castDoubleToWord64 :: Double -> Word64-castDoubleToWord64 (D# d#) = W64# (stgDoubleToWord64 d#)--foreign import prim "stg_doubleToWord64zh"-#if WORD_SIZE_IN_BITS == 64-    stgDoubleToWord64 :: Double# -> Word#-#else-    stgDoubleToWord64 :: Double# -> Word64#-#endif
− GHC/Float/ConversionUtils.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}-{-# OPTIONS_GHC -O2 #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Float.ConversionUtils--- Copyright   :  (c) Daniel Fischer 2010--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Utilities for conversion between Double/Float and Rational-----------------------------------------------------------------------------------#include "MachDeps.h"--module GHC.Float.ConversionUtils ( elimZerosInteger, elimZerosInt# ) where--import GHC.Base-import GHC.Num.Integer--default ()--#if WORD_SIZE_IN_BITS < 64--#define TO64    integerToInt64#---- Double mantissae have 53 bits, too much for Int#-elim64# :: Int64# -> Int# -> (# Integer, Int# #)-elim64# n e =-    case zeroCount (int64ToInt# n) of-      t | isTrue# (e <=# t) -> (# integerFromInt64# (uncheckedIShiftRA64# n e), 0# #)-        | isTrue# (t <# 8#) -> (# integerFromInt64# (uncheckedIShiftRA64# n t), e -# t #)-        | otherwise         -> elim64# (uncheckedIShiftRA64# n 8#) (e -# 8#)--#else--#define TO64    integerToInt#---- Double mantissae fit it Int#-elim64# :: Int# -> Int# -> (# Integer, Int# #)-elim64# = elimZerosInt#--#endif--{-# INLINE elimZerosInteger #-}-elimZerosInteger :: Integer -> Int# -> (# Integer, Int# #)-elimZerosInteger m e = elim64# (TO64 m) e--elimZerosInt# :: Int# -> Int# -> (# Integer, Int# #)-elimZerosInt# n e =-    case zeroCount n of-      t | isTrue# (e <=# t) -> (# IS (uncheckedIShiftRA# n e), 0# #)-        | isTrue# (t <# 8#) -> (# IS (uncheckedIShiftRA# n t), e -# t #)-        | otherwise         -> elimZerosInt# (uncheckedIShiftRA# n 8#) (e -# 8#)---- | Number of trailing zero bits in a byte-zeroCount :: Int# -> Int#-zeroCount i = int8ToInt# (indexInt8OffAddr# arr (word2Int# (narrow8Word# (int2Word# i)))) -- index must be in [0,255]-  where-    arr = "\8\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\6\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\7\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\6\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0"#
− GHC/Float/RealFracMethods.hs 
@@ -1,340 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Float.RealFracMethods--- Copyright   :  (c) Daniel Fischer 2010--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Methods for the RealFrac instances for 'Float' and 'Double',--- with specialised versions for 'Int'.------ Moved to their own module to not bloat GHC.Float further.-----------------------------------------------------------------------------------#include "MachDeps.h"--module GHC.Float.RealFracMethods-    ( -- * Double methods-      -- ** Integer results-      properFractionDoubleInteger-    , truncateDoubleInteger-    , floorDoubleInteger-    , ceilingDoubleInteger-    , roundDoubleInteger-      -- ** Int results-    , properFractionDoubleInt-    , floorDoubleInt-    , ceilingDoubleInt-    , roundDoubleInt-      -- * Double/Int conversions, wrapped primops-    , double2Int-    , int2Double-      -- * Float methods-      -- ** Integer results-    , properFractionFloatInteger-    , truncateFloatInteger-    , floorFloatInteger-    , ceilingFloatInteger-    , roundFloatInteger-      -- ** Int results-    , properFractionFloatInt-    , floorFloatInt-    , ceilingFloatInt-    , roundFloatInt-      -- * Float/Int conversions, wrapped primops-    , float2Int-    , int2Float-    ) where--import GHC.Num.Integer--import GHC.Base-import GHC.Num ()--#if WORD_SIZE_IN_BITS < 64--#define TO64 integerToInt64#-#define FROM64 integerFromInt64#-#define MINUS64 subInt64#-#define NEGATE64 negateInt64#--#else--#define TO64 integerToInt#-#define FROM64 IS-#define MINUS64 ( -# )-#define NEGATE64 negateInt#--uncheckedIShiftRA64# :: Int# -> Int# -> Int#-uncheckedIShiftRA64# = uncheckedIShiftRA#--uncheckedIShiftL64# :: Int# -> Int# -> Int#-uncheckedIShiftL64# = uncheckedIShiftL#--#endif--default ()-----------------------------------------------------------------------------------                              Float Methods                               ------------------------------------------------------------------------------------- Special Functions for Int, nice, easy and fast.--- They should be small enough to be inlined automatically.---- We have to test for ±0.0 to avoid returning -0.0 in the second--- component of the pair. Unfortunately the branching costs a lot--- of performance.-properFractionFloatInt :: Float -> (Int, Float)-properFractionFloatInt (F# x) =-    if isTrue# (x `eqFloat#` 0.0#)-        then (I# 0#, F# 0.0#)-        else case float2Int# x of-                n -> (I# n, F# (x `minusFloat#` int2Float# n))---- truncateFloatInt = float2Int--floorFloatInt :: Float -> Int-floorFloatInt (F# x) =-    case float2Int# x of-      n | isTrue# (x `ltFloat#` int2Float# n) -> I# (n -# 1#)-        | otherwise                           -> I# n--ceilingFloatInt :: Float -> Int-ceilingFloatInt (F# x) =-    case float2Int# x of-      n | isTrue# (int2Float# n `ltFloat#` x) -> I# (n +# 1#)-        | otherwise                           -> I# n--roundFloatInt :: Float -> Int-roundFloatInt x = float2Int (c_rintFloat x)---- Functions with Integer results---- With the new code generator in GHC 7, the explicit bit-fiddling is--- slower than the old code for values of small modulus, but when the--- 'Int' range is left, the bit-fiddling quickly wins big, so we use that.--- If the methods are called on smallish values, hopefully people go--- through Int and not larger types.---- Note: For negative exponents, we must check the validity of the shift--- distance for the right shifts of the mantissa.--{-# INLINE properFractionFloatInteger #-}-properFractionFloatInteger :: Float -> (Integer, Float)-properFractionFloatInteger v@(F# x) =-    case decodeFloat_Int# x of-      (# m, e #)-        | isTrue# (e <# 0#) ->-          case negateInt# e of-            s | isTrue# (s ># 23#) -> (0, v)-              | isTrue# (m <#  0#) ->-                case negateInt# (negateInt# m `uncheckedIShiftRA#` s) of-                  k -> (IS k,-                            case m -# (k `uncheckedIShiftL#` s) of-                              r -> F# (integerEncodeFloat# (IS r) e))-              | otherwise           ->-                case m `uncheckedIShiftRL#` s of-                  k -> (IS k,-                            case m -# (k `uncheckedIShiftL#` s) of-                              r -> F# (integerEncodeFloat# (IS r) e))-        | otherwise -> (integerShiftL# (IS m) (int2Word# e), F# 0.0#)--{-# INLINE truncateFloatInteger #-}-truncateFloatInteger :: Float -> Integer-truncateFloatInteger x =-    case properFractionFloatInteger x of-      (n, _) -> n---- floor is easier for negative numbers than truncate, so this gets its--- own implementation, it's a little faster.-{-# INLINE floorFloatInteger #-}-floorFloatInteger :: Float -> Integer-floorFloatInteger (F# x) =-    case decodeFloat_Int# x of-      (# m, e #)-        | isTrue# (e <# 0#) ->-          case negateInt# e of-            s | isTrue# (s ># 23#) -> if isTrue# (m <# 0#) then (-1) else 0-              | otherwise          -> IS (m `uncheckedIShiftRA#` s)-        | otherwise -> integerShiftL# (IS m) (int2Word# e)---- ceiling x = -floor (-x)--- If giving this its own implementation is faster at all,--- it's only marginally so, hence we keep it short.-{-# INLINE ceilingFloatInteger #-}-ceilingFloatInteger :: Float -> Integer-ceilingFloatInteger (F# x) =-    integerNegate (floorFloatInteger (F# (negateFloat# x)))--{-# INLINE roundFloatInteger #-}-roundFloatInteger :: Float -> Integer-roundFloatInteger x = float2Integer (c_rintFloat x)-----------------------------------------------------------------------------------                              Double Methods                              ------------------------------------------------------------------------------------- Special Functions for Int, nice, easy and fast.--- They should be small enough to be inlined automatically.---- We have to test for ±0.0 to avoid returning -0.0 in the second--- component of the pair. Unfortunately the branching costs a lot--- of performance.-properFractionDoubleInt :: Double -> (Int, Double)-properFractionDoubleInt (D# x) =-    if isTrue# (x ==## 0.0##)-        then (I# 0#, D# 0.0##)-        else case double2Int# x of-                n -> (I# n, D# (x -## int2Double# n))---- truncateDoubleInt = double2Int--floorDoubleInt :: Double -> Int-floorDoubleInt (D# x) =-    case double2Int# x of-      n | isTrue# (x <## int2Double# n) -> I# (n -# 1#)-        | otherwise                     -> I# n--ceilingDoubleInt :: Double -> Int-ceilingDoubleInt (D# x) =-    case double2Int# x of-      n | isTrue# (int2Double# n <## x) -> I# (n +# 1#)-        | otherwise                     -> I# n--roundDoubleInt :: Double -> Int-roundDoubleInt x = double2Int (c_rintDouble x)---- Functions with Integer results---- The new Code generator isn't quite as good for the old 'Double' code--- as for the 'Float' code, so for 'Double' the bit-fiddling also wins--- when the values have small modulus.---- When the exponent is negative, all mantissae have less than 64 bits--- and the right shifting of sized types is much faster than that of--- 'Integer's, especially when we can---- Note: For negative exponents, we must check the validity of the shift--- distance for the right shifts of the mantissa.--{-# INLINE properFractionDoubleInteger #-}-properFractionDoubleInteger :: Double -> (Integer, Double)-properFractionDoubleInteger v@(D# x) =-    case integerDecodeDouble# x of-      (# m, e #)-        | isTrue# (e <# 0#) ->-          case negateInt# e of-            s | isTrue# (s ># 52#) -> (0, v)-              | m < 0                 ->-                case TO64 (integerNegate m) of-                  n ->-                    case n `uncheckedIShiftRA64#` s of-                      k ->-                        (FROM64 (NEGATE64 k),-                          case MINUS64 n (k `uncheckedIShiftL64#` s) of-                            r ->-                              D# (integerEncodeDouble# (FROM64 (NEGATE64 r)) e))-              | otherwise           ->-                case TO64 m of-                  n ->-                    case n `uncheckedIShiftRA64#` s of-                      k -> (FROM64 k,-                            case MINUS64 n (k `uncheckedIShiftL64#` s) of-                              r -> D# (integerEncodeDouble# (FROM64 r) e))-        | otherwise -> (integerShiftL# m (int2Word# e), D# 0.0##)--{-# INLINE truncateDoubleInteger #-}-truncateDoubleInteger :: Double -> Integer-truncateDoubleInteger x =-    case properFractionDoubleInteger x of-      (n, _) -> n---- floor is easier for negative numbers than truncate, so this gets its--- own implementation, it's a little faster.-{-# INLINE floorDoubleInteger #-}-floorDoubleInteger :: Double -> Integer-floorDoubleInteger (D# x) =-    case integerDecodeDouble# x of-      (# m, e #)-        | isTrue# (e <# 0#) ->-          case negateInt# e of-            s | isTrue# (s ># 52#) -> if m < 0 then (-1) else 0-              | otherwise          ->-                case TO64 m of-                  n -> FROM64 (n `uncheckedIShiftRA64#` s)-        | otherwise -> integerShiftL# m (int2Word# e)--{-# INLINE ceilingDoubleInteger #-}-ceilingDoubleInteger :: Double -> Integer-ceilingDoubleInteger (D# x) =-    integerNegate (floorDoubleInteger (D# (negateDouble# x)))--{-# INLINE roundDoubleInteger #-}-roundDoubleInteger :: Double -> Integer-roundDoubleInteger x = double2Integer (c_rintDouble x)---- Wrappers around double2Int#, int2Double#, float2Int# and int2Float#,--- we need them here, so we move them from GHC.Float and re-export them--- explicitly from there.--double2Int :: Double -> Int-double2Int (D# x) = I# (double2Int# x)--int2Double :: Int -> Double-int2Double (I# i) = D# (int2Double# i)--float2Int :: Float -> Int-float2Int (F# x) = I# (float2Int# x)--int2Float :: Int -> Float-int2Float (I# i) = F# (int2Float# i)---- Quicker conversions from 'Double' and 'Float' to 'Integer',--- assuming the floating point value is integral.------ Note: Since the value is integral, the exponent can't be less than--- (-TYP_MANT_DIG), so we need not check the validity of the shift--- distance for the right shifts here.--{-# INLINE double2Integer #-}-double2Integer :: Double -> Integer-double2Integer (D# x) =-    case integerDecodeDouble# x of-      (# m, e #)-        | isTrue# (e <# 0#) ->-          case TO64 m of-            n -> FROM64 (n `uncheckedIShiftRA64#` negateInt# e)-        | otherwise -> integerShiftL# m (int2Word# e)--{-# INLINE float2Integer #-}-float2Integer :: Float -> Integer-float2Integer (F# x) =-    case decodeFloat_Int# x of-      (# m, e #)-        | isTrue# (e <# 0#) -> IS (m `uncheckedIShiftRA#` negateInt# e)-        | otherwise         -> integerShiftL# (IS m) (int2Word# e)---- Foreign imports, the rounding is done faster in C when the value--- isn't integral, so we call out for rounding. For values of large--- modulus, calling out to C is slower than staying in Haskell, but--- presumably 'round' is mostly called for values with smaller modulus,--- when calling out to C is a major win.--- For all other functions, calling out to C gives at most a marginal--- speedup for values of small modulus and is much slower than staying--- in Haskell for values of large modulus, so those are done in Haskell.--foreign import ccall unsafe "rintDouble"-    c_rintDouble :: Double -> Double--foreign import ccall unsafe "rintFloat"-    c_rintFloat :: Float -> Float-
− GHC/Foreign.hs 
@@ -1,329 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Foreign--- Copyright   :  (c) The University of Glasgow, 2008-2011--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Foreign marshalling support for CStrings with configurable encodings-----------------------------------------------------------------------------------module GHC.Foreign (-    -- * C strings with a configurable encoding--    -- conversion of C strings into Haskell strings-    ---    peekCString,-    peekCStringLen,--    -- conversion of Haskell strings into C strings-    ---    newCString,-    newCStringLen,--    -- conversion of Haskell strings into C strings using temporary storage-    ---    withCString,-    withCStringLen,-    withCStringsLen,--    charIsRepresentable,-  ) where--import Foreign.Marshal.Array-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable--import Data.Word---- Imports for the locale-encoding version of marshallers--import Data.Tuple (fst)--import GHC.Show ( show )--import Foreign.Marshal.Alloc-import Foreign.ForeignPtr--import GHC.Debug-import GHC.List-import GHC.Num-import GHC.Base--import GHC.IO-import GHC.IO.Exception-import GHC.IO.Buffer-import GHC.IO.Encoding.Types---c_DEBUG_DUMP :: Bool-c_DEBUG_DUMP = False--putDebugMsg :: String -> IO ()-putDebugMsg | c_DEBUG_DUMP = debugLn-            | otherwise    = const (return ())----- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle:-type CString    = Ptr CChar-type CStringLen = (Ptr CChar, Int)---- exported functions--- ---------------------- | Marshal a NUL terminated C string into a Haskell string.----peekCString    :: TextEncoding -> CString -> IO String-peekCString enc cp = do-    sz <- lengthArray0 nUL cp-    peekEncodedCString enc (cp, sz * cCharSize)---- | Marshal a C string with explicit length into a Haskell string.----peekCStringLen           :: TextEncoding -> CStringLen -> IO String-peekCStringLen = peekEncodedCString---- | Marshal a Haskell string into a NUL terminated C string.------ * the Haskell string may /not/ contain any NUL characters------ * new storage is allocated for the C string and must be---   explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCString :: TextEncoding -> String -> IO CString-newCString enc = liftM fst . newEncodedCString enc True---- | Marshal a Haskell string into a C string (ie, character array) with--- explicit length information.------ * new storage is allocated for the C string and must be---   explicitly freed using 'Foreign.Marshal.Alloc.free' or---   'Foreign.Marshal.Alloc.finalizerFree'.----newCStringLen     :: TextEncoding -> String -> IO CStringLen-newCStringLen enc = newEncodedCString enc False---- | Marshal a Haskell string into a NUL terminated C string using temporary--- storage.------ * the Haskell string may /not/ contain any NUL characters------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a-withCString enc s act = withEncodedCString enc True s $ \(cp, _sz) -> act cp---- | Marshal a Haskell string into a C string (ie, character array)--- in temporary storage, with explicit length information.------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCStringLen         :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a-withCStringLen enc = withEncodedCString enc False---- | Marshal a list of Haskell strings into an array of NUL terminated C strings--- using temporary storage.------ * the Haskell strings may /not/ contain any NUL characters------ * the memory is freed when the subcomputation terminates (either---   normally or via an exception), so the pointer to the temporary---   storage must /not/ be used after this.----withCStringsLen :: TextEncoding-                -> [String]-                -> (Int -> Ptr CString -> IO a)-                -> IO a-withCStringsLen enc strs f = go [] strs-  where-  go cs (s:ss) = withCString enc s $ \c -> go (c:cs) ss-  go cs [] = withArrayLen (reverse cs) f---- | Determines whether a character can be accurately encoded in a--- 'Foreign.C.String.CString'.------ Pretty much anyone who uses this function is in a state of sin because--- whether or not a character is encodable will, in general, depend on the--- context in which it occurs.-charIsRepresentable :: TextEncoding -> Char -> IO Bool--- We force enc explicitly because `catch` is lazy in its--- first argument. We would probably like to force c as well,--- but unfortunately worker/wrapper produces very bad code for--- that.------ TODO If this function is performance-critical, it would probably--- pay to use a single-character specialization of withCString. That--- would allow worker/wrapper to actually eliminate Char boxes, and--- would also get rid of the completely unnecessary cons allocation.-charIsRepresentable !enc c =-  withCString enc [c]-              (\cstr -> do str <- peekCString enc cstr-                           case str of-                             [ch] | ch == c -> pure True-                             _ -> pure False)-    `catch`-       \(_ :: IOException) -> pure False---- auxiliary definitions--- -------------------------- C's end of string character-nUL :: CChar-nUL  = 0---- Size of a CChar in bytes-cCharSize :: Int-cCharSize = sizeOf (undefined :: CChar)---{-# INLINE peekEncodedCString #-}-peekEncodedCString :: TextEncoding -- ^ Encoding of CString-                   -> CStringLen-                   -> IO String    -- ^ String in Haskell terms-peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes)-  = bracket mk_decoder close $ \decoder -> do-      let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII-      from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p)-      to <- newCharBuffer chunk_size WriteBuffer--      let go !iteration from = do-            (why, from', to') <- encode decoder from to-            if isEmptyBuffer from'-             then-              -- No input remaining: @why@ will be InputUnderflow, but we don't care-              withBuffer to' $ peekArray (bufferElems to')-             else do-              -- Input remaining: what went wrong?-              putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why)-              (from'', to'') <- case why of InvalidSequence -> recover decoder from' to' -- These conditions are equally bad because-                                            InputUnderflow  -> recover decoder from' to' -- they indicate malformed/truncated input-                                            OutputUnderflow -> return (from', to')       -- We will have more space next time round-              putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'')-              putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'')-              to_chars <- withBuffer to'' $ peekArray (bufferElems to'')-              fmap (to_chars++) $ go (iteration + 1) from''--      go (0 :: Int) from0--{-# INLINE withEncodedCString #-}-withEncodedCString :: TextEncoding         -- ^ Encoding of CString to create-                   -> Bool                 -- ^ Null-terminate?-                   -> String               -- ^ String to encode-                   -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory-                   -> IO a-withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act-  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do-      from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p--      let go !iteration to_sz_bytes = do-           putDebugMsg ("withEncodedCString: " ++ show iteration)-           allocaBytes to_sz_bytes $ \to_p -> do-            -- See Note [Check *before* fill in withEncodedCString] about why-            -- this is subtle.-            mb_res <- tryFillBuffer encoder null_terminate from to_p to_sz_bytes-            case mb_res of-              Nothing  -> go (iteration + 1) (to_sz_bytes * 2)-              Just to_buf -> withCStringBuffer to_buf null_terminate act--      -- If the input string is ASCII, this value will ensure we only allocate once-      go (0 :: Int) (cCharSize * (sz + 1))--withCStringBuffer :: Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r-withCStringBuffer to_buf null_terminate act = do-  let bytes = bufferElems to_buf-  withBuffer to_buf $ \to_ptr -> do-    when null_terminate $ pokeElemOff to_ptr (bufR to_buf) 0-    act (castPtr to_ptr, bytes) -- NB: the length information is specified as being in *bytes*--{-# INLINE newEncodedCString #-}-newEncodedCString :: TextEncoding  -- ^ Encoding of CString to create-                  -> Bool          -- ^ Null-terminate?-                  -> String        -- ^ String to encode-                  -> IO CStringLen-newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s-  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do-      from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p--      let go !iteration to_p to_sz_bytes = do-           putDebugMsg ("newEncodedCString: " ++ show iteration)-           mb_res <- tryFillBuffer encoder null_terminate from to_p to_sz_bytes-           case mb_res of-             Nothing  -> do-                 let to_sz_bytes' = to_sz_bytes * 2-                 to_p' <- reallocBytes to_p to_sz_bytes'-                 go (iteration + 1) to_p' to_sz_bytes'-             Just to_buf -> withCStringBuffer to_buf null_terminate return--      -- If the input string is ASCII, this value will ensure we only allocate once-      let to_sz_bytes = cCharSize * (sz + 1)-      to_p <- mallocBytes to_sz_bytes-      go (0 :: Int) to_p to_sz_bytes---tryFillBuffer :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int-                    ->  IO (Maybe (Buffer Word8))-tryFillBuffer encoder null_terminate from0 to_p to_sz_bytes = do-    to_fp <- newForeignPtr_ to_p-    go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer)-  where-    go !iteration (from, to) = do-      (why, from', to') <- encode encoder from to-      putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from')-      if isEmptyBuffer from'-       then if null_terminate && bufferAvailable to' == 0-             then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer-             else return (Just to')-       else case why of -- We didn't consume all of the input-              InputUnderflow  -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad-              InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid-              OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more-{--Note [Check *before* fill in withEncodedCString]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It's very important that the size check and readjustment peformed by tryFillBuffer-happens before the continuation is called. The size check is the part which can-fail, the call to the continuation never fails and so the caller should respond-first to the size check failing and *then* call the continuation. Making this evident-to the compiler avoids historic space leaks.--In a previous interation of this code we had a pattern that, somewhat simplified,-looked like this:--go :: State -> (State -> IO a) -> IO a-go state action =-    case tryFillBufferAndCall state action of-        Left state' -> go state' action-        Right result -> result--`tryFillBufferAndCall` performed some checks, and then we either called action,-or we modified the state and tried again.-This went wrong because `action` can be a function closure containing a reference to-a lazy data structure. If we call action directly, without retaining any references-to action, that is fine. The data structure is consumed as it is produced and we operate-in constant space.--However the failure branch `go state' action` *does* capture a reference to action.-This went wrong because the reference to action in the failure branch only becomes-unreachable *after* action returns. This means we keep alive the function closure-for `action` until `action` returns. Which in turn keeps alive the *whole* lazy list-via `action` until the action has fully run.-This went wrong in #20107, where the continuation kept an entire lazy bytestring alive-rather than allowing it to be incrementaly consumed and collected.--}-
− GHC/ForeignPtr.hs 
@@ -1,670 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.ForeignPtr--- Copyright   :  (c) The University of Glasgow, 1992-2003--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ GHC's implementation of the 'ForeignPtr' data type.-----------------------------------------------------------------------------------module GHC.ForeignPtr-  (-        -- * Types-        ForeignPtr(..),-        ForeignPtrContents(..),-        Finalizers(..),-        FinalizerPtr,-        FinalizerEnvPtr,-        -- * Create-        newForeignPtr_,-        mallocForeignPtr,-        mallocPlainForeignPtr,-        mallocForeignPtrBytes,-        mallocPlainForeignPtrBytes,-        mallocForeignPtrAlignedBytes,-        mallocPlainForeignPtrAlignedBytes,-        newConcForeignPtr,-        -- * Add Finalizers-        addForeignPtrFinalizer,-        addForeignPtrFinalizerEnv,-        addForeignPtrConcFinalizer,-        -- * Conversion-        unsafeForeignPtrToPtr,-        castForeignPtr,-        plusForeignPtr,-        -- * Control over lifetype-        withForeignPtr,-        unsafeWithForeignPtr,-        touchForeignPtr,-        -- * Finalization-        finalizeForeignPtr-        -- * Commentary-        -- $commentary-  ) where--import Foreign.Storable-import Data.Foldable    ( sequence_ )--import GHC.Show-import GHC.Base-import GHC.IORef-import GHC.STRef        ( STRef(..) )-import GHC.Ptr          ( Ptr(..), FunPtr(..) )--import Unsafe.Coerce    ( unsafeCoerce )---- |The type 'ForeignPtr' represents references to objects that are--- maintained in a foreign language, i.e., that are not part of the--- data structures usually managed by the Haskell storage manager.--- The essential difference between 'ForeignPtr's and vanilla memory--- references of type @Ptr a@ is that the former may be associated--- with /finalizers/. A finalizer is a routine that is invoked when--- the Haskell storage manager detects that - within the Haskell heap--- and stack - there are no more references left that are pointing to--- the 'ForeignPtr'.  Typically, the finalizer will, then, invoke--- routines in the foreign language that free the resources bound by--- the foreign object.------ The 'ForeignPtr' is parameterised in the same way as 'Ptr'.  The--- type argument of 'ForeignPtr' should normally be an instance of--- class 'Storable'.----data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents-        -- The Addr# in the ForeignPtr object is intentionally stored-        -- separately from the finalizer. The primary aim of the-        -- representation is to make withForeignPtr efficient; in fact,-        -- withForeignPtr should be just as efficient as unpacking a-        -- Ptr, and multiple withForeignPtrs can share an unpacked-        -- ForeignPtr. As a secondary benefit, this representation-        -- allows pointers to subregions within the same overall block-        -- to share the same finalizer (see 'plusForeignPtr'). Note-        -- that touchForeignPtr only has to touch the ForeignPtrContents-        -- object, because that ensures that whatever the finalizer is-        -- attached to is kept alive.---- | Functions called when a 'ForeignPtr' is finalized. Note that--- C finalizers and Haskell finalizers cannot be mixed.-data Finalizers-  = NoFinalizers-    -- ^ No finalizer. If there is no intent to add a finalizer at-    -- any point in the future, consider 'FinalPtr' or 'PlainPtr' instead-    -- since these perform fewer allocations.-  | CFinalizers (Weak# ())-    -- ^ Finalizers are all C functions.-  | HaskellFinalizers [IO ()]-    -- ^ Finalizers are all Haskell functions.---- | Controls finalization of a 'ForeignPtr', that is, what should happen--- if the 'ForeignPtr' becomes unreachable. Visually, these data constructors--- are appropriate in these scenarios:------ >                           Memory backing pointer is--- >                            GC-Managed   Unmanaged--- > Finalizer functions are: +------------+-----------------+--- >                 Allowed  | MallocPtr  | PlainForeignPtr |--- >                          +------------+-----------------+--- >              Prohibited  | PlainPtr   | FinalPtr        |--- >                          +------------+-----------------+-data ForeignPtrContents-  = PlainForeignPtr !(IORef Finalizers)-    -- ^ The pointer refers to unmanaged memory that was allocated by-    -- a foreign function (typically using @malloc@). The finalizer-    -- frequently calls the C function @free@ or some variant of it.-  | FinalPtr-    -- ^ The pointer refers to unmanaged memory that should not be freed when-    -- the 'ForeignPtr' becomes unreachable. Functions that add finalizers-    -- to a 'ForeignPtr' throw exceptions when the 'ForeignPtr' is backed by-    -- 'PlainPtr'Most commonly, this is used with @Addr#@ literals.-    -- See Note [Why FinalPtr].-    ---    -- @since 4.15-  | MallocPtr (MutableByteArray# RealWorld) !(IORef Finalizers)-    -- ^ The pointer refers to a byte array.-    -- The 'MutableByteArray#' field means that the 'MutableByteArray#' is-    -- reachable (by GC) whenever the 'ForeignPtr' is reachable. When the-    -- 'ForeignPtr' becomes unreachable, the runtime\'s normal GC recovers-    -- the memory backing it. Here, the finalizer function intended to be used-    -- to @free()@ any ancillary *unmanaged* memory pointed to by the-    -- 'MutableByteArray#'. See the @zlib@ library for an example of this use.-    ---    -- 1. Invariant: The 'Addr#' in the parent 'ForeignPtr' is an interior-    --    pointer into this 'MutableByteArray#'.-    -- 2. Invariant: The 'MutableByteArray#' is pinned, so the 'Addr#' does not-    --    get invalidated by the GC moving the byte array.-    -- 3. Invariant: A 'MutableByteArray#' must not be associated with more than-    --    one set of finalizers. For example, this is sound:-    ---    --    > incrGood :: ForeignPtr Word8 -> ForeignPtr Word8-    --    > incrGood (ForeignPtr p (MallocPtr m f)) = ForeignPtr (plusPtr p 1) (MallocPtr m f)-    ---    --    But this is unsound:-    ---    --    > incrBad :: ForeignPtr Word8 -> IO (ForeignPtr Word8)-    --    > incrBad (ForeignPtr p (MallocPtr m _)) = do-    --    >   f <- newIORef NoFinalizers-    --    >   pure (ForeignPtr p (MallocPtr m f))-  | PlainPtr (MutableByteArray# RealWorld)-    -- ^ The pointer refers to a byte array. Finalization is not-    -- supported. This optimizes @MallocPtr@ by avoiding the allocation-    -- of a @MutVar#@ when it is known that no one will add finalizers to-    -- the @ForeignPtr@. Functions that add finalizers to a 'ForeignPtr'-    -- throw exceptions when the 'ForeignPtr' is backed by 'PlainPtr'.-    -- The invariants that apply to 'MallocPtr' apply to 'PlainPtr' as well.---- Note [Why FinalPtr]------ FinalPtr exists as an optimization for foreign pointers created--- from Addr# literals. Most commonly, this happens in the bytestring--- library, where the combination of OverloadedStrings and a rewrite--- rule overloads String literals as ByteString literals. See the--- rule "ByteString packChars/packAddress" in--- bytestring:Data.ByteString.Internal. Prior to the--- introduction of FinalPtr, bytestring used PlainForeignPtr (in--- Data.ByteString.Internal.unsafePackAddress) to handle such literals.--- With O2 optimization, the resulting Core from a GHC patched with a--- known-key cstringLength# function but without FinalPtr looked like:------   RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}---   stringOne1 = "hello beautiful world"#---   RHS size: {terms: 11, types: 17, coercions: 0, joins: 0/0}---   stringOne---     = case newMutVar# NoFinalizers realWorld# of---       { (# ipv_i7b6, ipv1_i7b7 #) ->---       PS stringOne1 (PlainForeignPtr ipv1_i7b7) 0# 21#---       }------ After the introduction of FinalPtr, the bytestring library was modified--- so that the resulting Core was instead:------   RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}---   stringOne1 = "hello beautiful world"#---   RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0}---   stringOne = PS stringOne1 FinalPtr 0# 21#------ This improves performance in three ways:------ 1. More optimization opportunities. GHC is willing to inline the FinalPtr---    variant of stringOne into its use sites. This means the offset and length---    are eligible for case-of-known-literal. Previously, this never happened.--- 2. Smaller binaries. Setting up the thunk to call newMutVar# required---    machine instruction in the generated code. On x86_64, FinalPtr reduces---    the size of binaries by about 450 bytes per ByteString literal.--- 3. Smaller memory footprint. Previously, every ByteString literal resulted---    in the allocation of a MutVar# and a PlainForeignPtr data constructor.---    These both hang around until the ByteString goes out of scope. FinalPtr---    eliminates both of these sources of allocations. The MutVar# is not---    allocated because FinalPtr does not allow it, and the data constructor---    is not allocated because FinalPtr is a nullary data constructor.------ For more discussion of FinalPtr, see GHC MR #2165 and bytestring PR #191.---- | @since 2.01-instance Eq (ForeignPtr a) where-    p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q---- | @since 2.01-instance Ord (ForeignPtr a) where-    compare p q  =  compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)---- | @since 2.01-instance Show (ForeignPtr a) where-    showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)----- |A finalizer is represented as a pointer to a foreign function that, at--- finalisation time, gets as an argument a plain pointer variant of the--- foreign pointer that the finalizer is associated with.------ Note that the foreign function /must/ use the @ccall@ calling convention.----type FinalizerPtr a        = FunPtr (Ptr a -> IO ())-type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())--newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)------ ^Turns a plain memory reference into a foreign object by--- associating a finalizer - given by the monadic operation - with the--- reference.  The storage manager will start the finalizer, in a--- separate thread, some time after the last reference to the--- @ForeignPtr@ is dropped.  There is no guarantee of promptness, and--- in fact there is no guarantee that the finalizer will eventually--- run at all.------ Note that references from a finalizer do not necessarily prevent--- another object from being finalized.  If A's finalizer refers to B--- (perhaps using 'touchForeignPtr', then the only guarantee is that--- B's finalizer will never be started before A's.  If both A and B--- are unreachable, then both finalizers will start together.  See--- 'touchForeignPtr' for more on finalizer ordering.----newConcForeignPtr p finalizer-  = do fObj <- newForeignPtr_ p-       addForeignPtrConcFinalizer fObj finalizer-       return fObj--mallocForeignPtr :: Storable a => IO (ForeignPtr a)--- ^ Allocate some memory and return a 'ForeignPtr' to it.  The memory--- will be released automatically when the 'ForeignPtr' is discarded.------ 'mallocForeignPtr' is equivalent to------ >    do { p <- malloc; newForeignPtr finalizerFree p }------ although it may be implemented differently internally: you may not--- assume that the memory returned by 'mallocForeignPtr' has been--- allocated with 'Foreign.Marshal.Alloc.malloc'.------ GHC notes: 'mallocForeignPtr' has a heavily optimised--- implementation in GHC.  It uses pinned memory in the garbage--- collected heap, so the 'ForeignPtr' does not require a finalizer to--- free the memory.  Use of 'mallocForeignPtr' and associated--- functions is strongly recommended in preference to--- 'Foreign.ForeignPtr.newForeignPtr' with a finalizer.----mallocForeignPtr = doMalloc undefined-  where doMalloc :: Storable b => b -> IO (ForeignPtr b)-        doMalloc a-          | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0"-          | otherwise = do-          r <- newIORef NoFinalizers-          IO $ \s ->-            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->-             (# s', ForeignPtr (mutableByteArrayContents# mbarr#)-                               (MallocPtr mbarr# r) #)-            }-            where !(I# size)  = sizeOf a-                  !(I# align) = alignment a---- | This function is similar to 'mallocForeignPtr', except that the--- size of the memory required is given explicitly as a number of bytes.-mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)-mallocForeignPtrBytes size | size < 0 =-  errorWithoutStackTrace "mallocForeignPtrBytes: size must be >= 0"-mallocForeignPtrBytes (I# size) = do-  r <- newIORef NoFinalizers-  IO $ \s ->-     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->-       (# s', ForeignPtr (mutableByteArrayContents# mbarr#)-                         (MallocPtr mbarr# r) #)-     }---- | This function is similar to 'mallocForeignPtrBytes', except that the--- size and alignment of the memory required is given explicitly as numbers of--- bytes.-mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)-mallocForeignPtrAlignedBytes size _align | size < 0 =-  errorWithoutStackTrace "mallocForeignPtrAlignedBytes: size must be >= 0"-mallocForeignPtrAlignedBytes (I# size) (I# align) = do-  r <- newIORef NoFinalizers-  IO $ \s ->-     case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->-       (# s', ForeignPtr (mutableByteArrayContents# mbarr#)-                         (MallocPtr mbarr# r) #)-     }---- | Allocate some memory and return a 'ForeignPtr' to it.  The memory--- will be released automatically when the 'ForeignPtr' is discarded.------ GHC notes: 'mallocPlainForeignPtr' has a heavily optimised--- implementation in GHC.  It uses pinned memory in the garbage--- collected heap, as for mallocForeignPtr. Unlike mallocForeignPtr, a--- ForeignPtr created with mallocPlainForeignPtr carries no finalizers.--- It is not possible to add a finalizer to a ForeignPtr created with--- mallocPlainForeignPtr. This is useful for ForeignPtrs that will live--- only inside Haskell (such as those created for packed strings).--- Attempts to add a finalizer to a ForeignPtr created this way, or to--- finalize such a pointer, will throw an exception.----mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)-mallocPlainForeignPtr = doMalloc undefined-  where doMalloc :: Storable b => b -> IO (ForeignPtr b)-        doMalloc a-          | I# size < 0 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0"-          | otherwise = IO $ \s ->-            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->-             (# s', ForeignPtr (mutableByteArrayContents# mbarr#)-                               (PlainPtr mbarr#) #)-            }-            where !(I# size)  = sizeOf a-                  !(I# align) = alignment a---- | This function is similar to 'mallocForeignPtrBytes', except that--- the internally an optimised ForeignPtr representation with no--- finalizer is used. Attempts to add a finalizer will cause an--- exception to be thrown.-mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)-mallocPlainForeignPtrBytes size | size < 0 =-  errorWithoutStackTrace "mallocPlainForeignPtrBytes: size must be >= 0"-mallocPlainForeignPtrBytes (I# size) = IO $ \s ->-    case newPinnedByteArray# size s      of { (# s', mbarr# #) ->-       (# s', ForeignPtr (mutableByteArrayContents# mbarr#)-                         (PlainPtr mbarr#) #)-     }---- | This function is similar to 'mallocForeignPtrAlignedBytes', except that--- the internally an optimised ForeignPtr representation with no--- finalizer is used. Attempts to add a finalizer will cause an--- exception to be thrown.-mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a)-mallocPlainForeignPtrAlignedBytes size _align | size < 0 =-  errorWithoutStackTrace "mallocPlainForeignPtrAlignedBytes: size must be >= 0"-mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s ->-    case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->-       (# s', ForeignPtr (mutableByteArrayContents# mbarr#)-                         (PlainPtr mbarr#) #)-     }--addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()--- ^ This function adds a finalizer to the given foreign object.  The--- finalizer will run /before/ all other finalizers for the same--- object which have already been registered.-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-  _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer or a final pointer"---- Note [MallocPtr finalizers] (#10904)------ When we have C finalizers for a MallocPtr, the memory is--- heap-resident and would normally be recovered by the GC before the--- finalizers run.  To prevent the memory from being reused too early,--- we attach the MallocPtr constructor to the "value" field of the--- weak pointer when we call mkWeak# in ensureCFinalizerWeak below.--- The GC will keep this field alive until the finalizers have run.--addForeignPtrFinalizerEnv ::-  FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()--- ^ Like 'addForeignPtrFinalizer' but the finalizer is passed an additional--- environment parameter.-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-  _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer or a final pointer"--addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()--- ^This function adds a finalizer to the given @ForeignPtr@.  The--- finalizer will run /before/ all other finalizers for the same--- object which have already been registered.------ This is a variant of @addForeignPtrFinalizer@, where the finalizer--- is an arbitrary @IO@ action.  When it is invoked, the finalizer--- will run in a new thread.------ NB. Be very careful with these finalizers.  One common trap is that--- if a finalizer references another finalized value, it does not--- prevent that value from being finalized.  In particular, 'System.IO.Handle's--- are finalized objects, so a finalizer should not refer to a--- 'System.IO.Handle' (including 'System.IO.stdout', 'System.IO.stdin', or--- 'System.IO.stderr').----addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer =-  addForeignPtrConcFinalizer_ c finalizer--addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO ()-addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do-  noFinalizers <- insertHaskellFinalizer r finalizer-  if noFinalizers-     then IO $ \s ->-              case r of { IORef (STRef r#) ->-              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 () finalizer' s of-                  (# s1, _ #) -> (# s1, () #)-     else return ()-  where-    finalizer' :: State# RealWorld -> (# State# RealWorld, () #)-    finalizer' = unIO (foreignPtrFinalizer r >> touch f)--addForeignPtrConcFinalizer_ _ _ =-  errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer or a final pointer"--insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool-insertHaskellFinalizer r f = do-  !wasEmpty <- atomicModifyIORefP r $ \finalizers -> case finalizers of-      NoFinalizers -> (HaskellFinalizers [f], True)-      HaskellFinalizers fs -> (HaskellFinalizers (f:fs), False)-      _ -> noMixingError-  return wasEmpty---- | A box around Weak#, private to this module.-data MyWeak = MyWeak (Weak# ())--insertCFinalizer ::-  IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> value -> IO ()-insertCFinalizer r fp flag ep p val = do-  MyWeak w <- ensureCFinalizerWeak r val-  IO $ \s -> case addCFinalizerToWeak# fp p flag ep w s of-      (# s1, 1# #) -> (# s1, () #)--      -- Failed to add the finalizer because some other thread-      -- has finalized w by calling foreignPtrFinalizer. We retry now.-      -- This won't be an infinite loop because that thread must have-      -- replaced the content of r before calling finalizeWeak#.-      (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p val) s1---- Read the weak reference from an IORef Finalizers, creating it if necessary.--- Throws an exception if HaskellFinalizers is encountered.-ensureCFinalizerWeak :: IORef Finalizers -> value -> IO MyWeak-ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do-  fin <- readIORef ref-  case fin of-      CFinalizers weak -> return (MyWeak weak)-      HaskellFinalizers{} -> noMixingError-      NoFinalizers -> IO $ \s ->-          case mkWeakNoFinalizer# r# (unsafeCoerce value) s of { (# s1, w #) ->-             -- See Note [MallocPtr finalizers] (#10904)-          case atomicModifyMutVar2# r# (update w) s1 of-              { (# s2, _, (_, (weak, needKill )) #) ->-          if needKill-            then case finalizeWeak# w s2 of { (# s3, _, _ #) ->-              (# s3, weak #) }-            else (# s2, weak #) }}-  where-      update _ fin@(CFinalizers w) = (fin, (MyWeak w, True))-      update w NoFinalizers = (CFinalizers w, (MyWeak w, False))-      update _ _ = noMixingError--noMixingError :: a-noMixingError = errorWithoutStackTrace $-   "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++-   "in the same ForeignPtr"---- Swap out the finalizers with NoFinalizers and then run them.-foreignPtrFinalizer :: IORef Finalizers -> IO ()-foreignPtrFinalizer r = do-  fs <- atomicSwapIORef r NoFinalizers-             -- atomic, see #7170-  case fs of-    NoFinalizers -> return ()-    CFinalizers w -> IO $ \s -> case finalizeWeak# w s of-        (# s1, 1#, f #) -> f s1-        (# s1, _, _ #) -> (# s1, () #)-    HaskellFinalizers actions -> sequence_ actions--newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)--- ^Turns a plain memory reference into a foreign pointer that may be--- associated with finalizers by using 'addForeignPtrFinalizer'.-newForeignPtr_ (Ptr obj) =  do-  r <- newIORef NoFinalizers-  return (ForeignPtr obj (PlainForeignPtr r))--withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b--- ^This is a way to look at the pointer living inside a--- foreign object.  This function takes a function which is--- applied to that pointer. The resulting 'IO' action is then--- executed. The foreign object is kept alive at least during--- the whole action, even if it is not used directly--- inside. Note that it is not safe to return the pointer from--- the action and use it after the action completes. All uses--- of the pointer should be inside the--- 'withForeignPtr' bracket.  The reason for--- this unsafeness is the same as for--- 'unsafeForeignPtrToPtr' below: the finalizer--- may run earlier than expected, because the compiler can only--- track usage of the 'ForeignPtr' object, not--- a 'Ptr' object made from it.------ This function is normally used for marshalling data to--- or from the object pointed to by the--- 'ForeignPtr', using the operations from the--- 'Storable' class.-withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->-  case f (unsafeForeignPtrToPtr fo) of-    IO action# -> keepAlive# r s action#---- | This is similar to 'withForeignPtr' but comes with an important caveat:--- the user must guarantee that the continuation does not diverge (e.g. loop or--- throw an exception). In exchange for this loss of generality, this function--- offers the ability of GHC to optimise more aggressively.------ Specifically, applications of the form:--- @--- unsafeWithForeignPtr fptr ('Control.Monad.forever' something)--- @------ See GHC issue #17760 for more information about the unsoundness behavior--- that this function can result in.-unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b-unsafeWithForeignPtr fo f = do-  r <- f (unsafeForeignPtrToPtr fo)-  touchForeignPtr fo-  return r--touchForeignPtr :: ForeignPtr a -> IO ()--- ^This function ensures that the foreign object in--- question is alive at the given place in the sequence of IO--- actions. However, this comes with a significant caveat: the contract above--- does not hold if GHC can demonstrate that the code preceeding--- @touchForeignPtr@ diverges (e.g. by looping infinitely or throwing an--- exception). For this reason, you are strongly advised to use instead--- 'withForeignPtr' where possible.------ Also, note that this function should not be used to express dependencies--- between finalizers on 'ForeignPtr's.  For example, if the finalizer for a--- 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second 'ForeignPtr' @F2@,--- then the only guarantee is that the finalizer for @F2@ is never started--- before the finalizer for @F1@.  They might be started together if for--- example both @F1@ and @F2@ are otherwise unreachable, and in that case the--- scheduler might end up running the finalizer for @F2@ first.------ In general, it is not recommended to use finalizers on separate--- objects with ordering constraints between them.  To express the--- ordering robustly requires explicit synchronisation using @MVar@s--- between the finalizers, but even then the runtime sometimes runs--- multiple finalizers sequentially in a single thread (for--- performance reasons), so synchronisation between finalizers could--- result in artificial deadlock.  Another alternative is to use--- explicit reference counting.----touchForeignPtr (ForeignPtr _ r) = touch r--touch :: ForeignPtrContents -> IO ()-touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)--unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a--- ^This function extracts the pointer component of a foreign--- pointer.  This is a potentially dangerous operations, as if the--- argument to 'unsafeForeignPtrToPtr' is the last usage--- occurrence of the given foreign pointer, then its finalizer(s) will--- be run, which potentially invalidates the plain pointer just--- obtained.  Hence, 'touchForeignPtr' must be used--- wherever it has to be guaranteed that the pointer lives on - i.e.,--- has another usage occurrence.------ To avoid subtle coding errors, hand written marshalling code--- should preferably use 'Foreign.ForeignPtr.withForeignPtr' rather--- than combinations of 'unsafeForeignPtrToPtr' and--- 'touchForeignPtr'.  However, the latter routines--- are occasionally preferred in tool generated marshalling code.-unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo--castForeignPtr :: ForeignPtr a -> ForeignPtr b--- ^This function casts a 'ForeignPtr'--- parameterised by one type into another type.-castForeignPtr = coerce--plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b--- ^Advances the given address by the given offset in bytes.------ The new 'ForeignPtr' shares the finalizer of the original,--- equivalent from a finalization standpoint to just creating another--- reference to the original. That is, the finalizer will not be--- called before the new 'ForeignPtr' is unreachable, nor will it be--- called an additional time due to this call, and the finalizer will--- be called with the same address that it would have had this call--- not happened, *not* the new address.------ @since 4.10.0.0-plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c---- | Causes the finalizers associated with a foreign pointer to be run--- immediately. The foreign pointer must not be used again after this--- function is called. If the foreign pointer does not support finalizers,--- this is a no-op.-finalizeForeignPtr :: ForeignPtr a -> IO ()-finalizeForeignPtr (ForeignPtr _ c) = case c of-  PlainForeignPtr ref -> foreignPtrFinalizer ref-  MallocPtr _ ref -> foreignPtrFinalizer ref-  PlainPtr{} -> return ()-  FinalPtr{} -> return ()--{- $commentary--This is a high-level overview of how 'ForeignPtr' works.-The implementation of 'ForeignPtr' must accomplish several goals:--1. Invoke a finalizer once a foreign pointer becomes unreachable.-2. Support augmentation of finalizers, i.e. 'addForeignPtrFinalizer'.-   As a motivating example, suppose that the payload of a foreign-   pointer is C struct @bar@ that has an optionally NULL pointer field-   @foo@ to an unmanaged heap object. Initially, @foo@ is NULL, and-   later the program uses @malloc@, initializes the object, and assigns-   @foo@ the address returned by @malloc@. When the foreign pointer-   becomes unreachable, it is now necessary to first @free@ the object-   pointed to by @foo@ and then invoke whatever finalizer was associated-   with @bar@. That is, finalizers must be invoked in the opposite order-   they are added.-3. Allow users to invoke a finalizer promptly if they know that the-   foreign pointer is unreachable, i.e. 'finalizeForeignPtr'.--How can these goals be accomplished? Goal 1 suggests that weak references-and finalizers (via 'Weak#' and 'mkWeak#') are necessary. But how should-they be used and what should their key be?  Certainly not 'ForeignPtr' or-'ForeignPtrContents'. See the warning in "GHC.Weak" about weak pointers with-lifted (non-primitive) keys. The two finalizer-supporting data constructors of-'ForeignPtr' have an @'IORef' 'Finalizers'@ (backed by 'MutVar#') field.-This gets used in two different ways depending on the kind of finalizer:--* 'HaskellFinalizers': The first @addForeignPtrConcFinalizer_@ call uses-  'mkWeak#' to attach the finalizer @foreignPtrFinalizer@ to the 'MutVar#'.-  The resulting 'Weak#' is discarded (see @addForeignPtrConcFinalizer_@).-  Subsequent calls to @addForeignPtrConcFinalizer_@ (goal 2) just add-  finalizers onto the list in the 'HaskellFinalizers' data constructor.-* 'CFinalizers': The first 'addForeignPtrFinalizer' call uses-  'mkWeakNoFinalizer#' to create a 'Weak#'. The 'Weak#' is preserved in the-  'CFinalizers' data constructor. Both the first call and subsequent-  calls (goal 2) use 'addCFinalizerToWeak#' to attach finalizers to the-  'Weak#' itself. Also, see Note [MallocPtr finalizers] for discussion of-  the key and value of this 'Weak#'.--In either case, the runtime invokes the appropriate finalizers when the-'ForeignPtr' becomes unreachable.--}
− GHC/GHCi.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.GHCi--- Copyright   :  (c) The University of Glasgow 2012--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The GHCi Monad lifting interface.------ EXPERIMENTAL! DON'T USE.-----------------------------------------------------------------------------------module GHC.GHCi {-# WARNING "This is an unstable interface." #-} (-        GHCiSandboxIO(..), NoIO()-    ) where--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)-class (Monad m) => GHCiSandboxIO m where-    ghciStepIO :: m a -> IO a---- | @since 4.4.0.0-instance GHCiSandboxIO IO where-    ghciStepIO = id---- | A monad that doesn't allow any IO.-newtype NoIO a = NoIO { noio :: IO a }---- | @since 4.8.0.0-instance Functor NoIO where-  fmap f (NoIO a) = NoIO (fmap f a)---- | @since 4.8.0.0-instance Applicative NoIO where-  pure a = NoIO (pure a)-  (<*>) = ap---- | @since 4.4.0.0-instance Monad NoIO where-    (>>=) k f = NoIO (noio k >>= noio . f)---- | @since 4.4.0.0-instance GHCiSandboxIO NoIO where-    ghciStepIO = noio-
− GHC/GHCi/Helpers.hs 
@@ -1,36 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  GHC.GHCi.Helpers--- Copyright   :  (c) The GHC Developers--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Various helpers used by the GHCi shell.-----------------------------------------------------------------------------------module GHC.GHCi.Helpers-  ( disableBuffering, flushAll-  , evalWrapper-  ) where--import System.IO-import System.Environment--disableBuffering :: IO ()-disableBuffering = do-  hSetBuffering stdin NoBuffering-  hSetBuffering stdout NoBuffering-  hSetBuffering stderr NoBuffering--flushAll :: IO ()-flushAll = do-  hFlush stdout-  hFlush stderr--evalWrapper :: String -> [String] -> IO a -> IO a-evalWrapper progName args m =-  withProgName progName (withArgs args m)
− GHC/Generics.hs 
@@ -1,1715 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE EmptyDataDeriving          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE NoImplicitPrelude          #-}-{-# LANGUAGE PolyKinds                  #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE Trustworthy                #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Generics--- Copyright   :  (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2014--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ @since 4.6.0.0------ If you're using @GHC.Generics@, you should consider using the--- <http://hackage.haskell.org/package/generic-deriving> package, which--- contains many useful generic functions.--module GHC.Generics  (--- * Introduction------ |------ 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--- datatype-generic function is then an overloaded function with instances--- for most of these type constructors, together with a wrapper that performs--- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need--- a few generic instances in order to implement functionality that works for any--- representable type.------ Representable types are collected in the 'Generic' class, which defines the--- associated type 'Rep' as well as conversion functions 'from' and 'to'.--- Typically, you will not define 'Generic' instances by hand, but have the compiler--- derive them for you.---- ** Representing datatypes------ |------ The key to defining your own datatype-generic functions is to understand how to--- represent datatypes using the given set of type constructors.------ Let us look at an example first:------ @--- data Tree a = Leaf a | Node (Tree a) (Tree a)---   deriving 'Generic'--- @------ The above declaration (which requires the language pragma @DeriveGeneric@)--- causes the following representation to be generated:------ @--- instance 'Generic' (Tree a) where---   type 'Rep' (Tree a) =---     'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)---       ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)---          ('S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---                 ('Rec0' a))---        ':+:'---        'C1' ('MetaCons \"Node\" 'PrefixI 'False)---          ('S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---                ('Rec0' (Tree a))---           ':*:'---           'S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---                ('Rec0' (Tree a))))---   ...--- @------ /Hint:/ You can obtain information about the code being generated from GHC by passing--- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using--- the @:kind!@ command.------ 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.------ Here is a reduced representation for @Tree@ with nearly all meta-information removed,--- for now keeping only the most essential aspects:------ @--- instance 'Generic' (Tree a) where---   type 'Rep' (Tree a) =---     'Rec0' a---     ':+:'---     ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a))--- @------ The @Tree@ datatype has two constructors. The representation of individual constructors--- is combined using the binary type constructor ':+:'.------ The first constructor consists of a single field, which is the parameter @a@. This is--- 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--- the binary type constructor ':*:'.------ Now let us explain the additional tags being used in the complete representation:------    * 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:------      * 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, 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' ('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------ |------ There are many datatype-generic functions that do not distinguish between positions that--- are parameters or positions that are recursive calls. There are also many datatype-generic--- functions that do not care about the names of datatypes and constructors at all. To keep--- the number of cases to consider in generic functions in such a situation to a minimum,--- it turns out that many of the type constructors introduced above are actually synonyms,--- defining them to be variants of a smaller set of constructors.---- *** Individual fields of constructors: 'K1'------ |------ The type constructor 'Rec0' is a variant of 'K1':------ @--- type 'Rec0' = 'K1' 'R'--- @------ 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'------ |------ The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1':------ @--- type 'S1' = 'M1' 'S'--- type 'C1' = 'M1' 'C'--- type 'D1' = 'M1' 'D'--- @------ The types 'S', 'C' and 'D' are once again type-level proxies, just used to create--- several variants of 'M1'.---- *** Additional generic representation type constructors------ |------ Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur--- in the representations of other datatypes.---- **** Empty datatypes: 'V1'------ |------ For empty datatypes, 'V1' is used as a representation. For example,------ @--- data Empty deriving 'Generic'--- @------ yields------ @--- instance 'Generic' Empty where---   type 'Rep' Empty =---     'D1' ('MetaData \"Empty\" \"Main\" \"package-name\" 'False) 'V1'--- @---- **** Constructors without fields: 'U1'------ |------ If a constructor has no arguments, then 'U1' is used as its representation. For example--- the representation of 'Bool' is------ @--- instance 'Generic' Bool where---   type 'Rep' Bool =---     '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------ |------ As ':+:' and ':*:' are just binary operators, one might ask what happens if the--- datatype has more than two constructors, or a constructor with more than two--- fields. The answer is simple: the operators are used several times, to combine--- all the constructors and fields as needed. However, users /should not rely on--- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is--- free to choose any nesting it prefers. (In practice, the current implementation--- tries to produce a more-or-less balanced nesting, so that the traversal of--- the structure of the datatype from the root to a particular component can be--- performed in logarithmic rather than linear time.)---- ** Defining datatype-generic functions------ |------ A datatype-generic function comprises two parts:------    1. /Generic instances/ for the function, implementing it for most of the representation---       type constructors introduced above.------    2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion---       between the original value and its `Rep`-based representation and then invokes the---       generic instances.------ As an example, let us look at a function @encode@ that produces a naive, but lossless--- bit encoding of values of various datatypes. So we are aiming to define a function------ @--- encode :: 'Generic' a => a -> [Bool]--- @------ where we use 'Bool' as our datatype for bits.------ For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized--- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation--- type constructors operate with kind @* -> *@ as base kind. But the type argument is never--- being used. This may be changed at some point in the future. The class has a single method,--- and we use the type we want our final function to have, but we replace the occurrences of--- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used).------ > class Encode' f where--- >   encode' :: f p -> [Bool]------ With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define--- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'.---- *** Definition of the generic representation types------ |------ In order to be able to do this, we need to know the actual definitions of these types:------ @--- data    'V1'        p                       -- lifted version of Empty--- data    'U1'        p = 'U1'                  -- lifted version of ()--- data    (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either'--- data    (':*:') f g p = (f p) ':*:' (g p)     -- lifted version of (,)--- newtype 'K1'    i c p = 'K1' { 'unK1' :: c }    -- a container for a c--- newtype 'M1'  i t f p = 'M1' { 'unM1' :: f p }  -- a wrapper--- @------ So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either',--- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value--- of a specific type @c@, and 'M1' wraps a value of the generic type argument,--- which in the lifted world is an @f p@ (where we do not care about @p@).---- *** Generic instances------ |------ To deal with the 'V1' case, we use the following code (which requires the pragma @EmptyCase@):------ @--- instance Encode' 'V1' where---   encode' x = case x of { }--- @------ There are no values of type @V1 p@ to pass, so it is impossible for this--- function to be invoked. One can ask why it is useful to define an instance--- for 'V1' at all in this case? Well, an empty type can be used as an argument--- to a non-empty type, and you might still want to encode the resulting type.--- As a somewhat contrived example, consider @[Empty]@, which is not an empty--- type, but contains just the empty list. The 'V1' instance ensures that we--- can call the generic function on such types.------ There is exactly one value of type 'U1', so encoding it requires no--- knowledge, and we can use zero bits:------ @--- instance Encode' 'U1' where---   encode' 'U1' = []--- @------ In the case for ':+:', we produce 'False' or 'True' depending on whether--- the constructor of the value provided is located on the left or on the right:------ @--- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where---   encode' ('L1' x) = False : encode' x---   encode' ('R1' x) = True  : encode' x--- @------ (Note that this encoding strategy may not be reliable across different--- versions of GHC. Recall that the compiler is free to choose any nesting--- of ':+:' it chooses, so if GHC chooses @(a ':+:' b) ':+:' c@, then the--- encoding for @a@ would be @[False, False]@, @b@ would be @[False, True]@,--- and @c@ would be @[True]@. However, if GHC chooses @a ':+:' (b ':+:' c)@,--- then the encoding for @a@ would be @[False]@, @b@ would be @[True, False]@,--- and @c@ would be @[True, True]@.)------ In the case for ':*:', we append the encodings of the two subcomponents:------ @--- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where---   encode' (x ':*:' y) = encode' x ++ encode' y--- @------ The case for 'K1' is rather interesting. Here, we call the final function--- @encode@ that we yet have to define, recursively. We will use another type--- class @Encode@ for that function:------ @--- instance (Encode c) => Encode' ('K1' i c) where---   encode' ('K1' x) = encode x--- @------ Note how we can define a uniform instance for 'M1', because we completely--- disregard all meta-information:------ @--- instance (Encode' f) => Encode' ('M1' i t f) where---   encode' ('M1' x) = encode' x--- @------ Unlike in 'K1', the instance for 'M1' refers to @encode'@, not @encode@.---- *** The wrapper and generic default------ |------ We now define class @Encode@ for the actual @encode@ function:------ @--- class Encode a where---   encode :: a -> [Bool]---   default encode :: (Generic a, Encode' (Rep a)) => a -> [Bool]---   encode x = encode' ('from' x)--- @------ The incoming @x@ is converted using 'from', then we dispatch to the--- generic instances using @encode'@. We use this as a default definition--- for @encode@. We need the @default encode@ signature because ordinary--- Haskell default methods must not introduce additional class constraints,--- but our generic default does.------ Defining a particular instance is now as simple as saying------ @--- instance (Encode a) => Encode (Tree a)--- @----#if 0--- /TODO:/ Add usage example?----#endif--- The generic default is being used. In the future, it will hopefully be--- possible to use @deriving Encode@ as well, but GHC does not yet support--- that syntax for this situation.------ Having @Encode@ as a class has the advantage that we can define--- non-generic special cases, which is particularly useful for abstract--- datatypes that have no structural representation. For example, given--- a suitable integer encoding function @encodeInt@, we can define------ @--- instance Encode Int where---   encode = encodeInt--- @---- *** Omitting generic instances------ |------ It is not always required to provide instances for all the generic--- representation types, but omitting instances restricts the set of--- datatypes the functions will work for:------    * If no ':+:' instance is given, the function may still work for---      empty datatypes or datatypes that have a single constructor,---      but will fail on datatypes with more than one constructor.------    * If no ':*:' instance is given, the function may still work for---      datatypes where each constructor has just zero or one field,---      in particular for enumeration types.------    * If no 'K1' instance is given, the function may still work for---      enumeration types, where no constructor has any fields.------    * If no 'V1' instance is given, the function may still work for---      any datatype that is not empty.------    * If no 'U1' instance is given, the function may still work for---      any datatype where each constructor has at least one field.------ An 'M1' instance is always required (but it can just ignore the--- meta-information, as is the case for @encode@ above).-#if 0--- *** Using meta-information------ |------ TODO-#endif--- ** Generic constructor classes------ |------ Datatype-generic functions as defined above work for a large class--- of datatypes, including parameterized datatypes. (We have used @Tree@--- as our example above, which is of kind @* -> *@.) However, the--- 'Generic' class ranges over types of kind @*@, and therefore, the--- resulting generic functions (such as @encode@) must be parameterized--- by a generic type argument of kind @*@.------ What if we want to define generic classes that range over type--- constructors (such as 'Data.Functor.Functor',--- 'Data.Traversable.Traversable', or 'Data.Foldable.Foldable')?---- *** The 'Generic1' class------ |------ Like 'Generic', there is a class 'Generic1' that defines a--- representation 'Rep1' and conversion functions 'from1' and 'to1',--- only that 'Generic1' ranges over types of kind @* -> *@. (More generally,--- it can range over types of kind @k -> *@, for any kind @k@, if the--- @PolyKinds@ extension is enabled. More on this later.)--- The 'Generic1' class is also derivable.------ The representation 'Rep1' is ever so slightly different from 'Rep'.--- Let us look at @Tree@ as an example again:------ @--- data Tree a = Leaf a | Node (Tree a) (Tree a)---   deriving 'Generic1'--- @------ The above declaration causes the following representation to be generated:------ @--- instance 'Generic1' Tree where---   type 'Rep1' Tree =---     'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)---       ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)---          ('S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---                'Par1')---        ':+:'---        'C1' ('MetaCons \"Node\" 'PrefixI 'False)---          ('S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---                ('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--- carry around the dummy type argument for kind-@*@-types, but there are--- already enough different names involved without duplicating each of--- these.)------ What's different is that we now use 'Par1' to refer to the parameter--- (and that parameter, which used to be @a@), is not mentioned explicitly--- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@.---- *** Representation of @* -> *@ types------ |------ Unlike 'Rec0', the 'Par1' and 'Rec1' type constructors do not--- map to 'K1'. They are defined directly, as follows:------ @--- newtype 'Par1'   p = 'Par1' { 'unPar1' ::   p } -- gives access to parameter p--- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper--- @------ In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply--- wraps an application of @f@ to @p@.------ Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation,--- namely when the datatype has a field that does not mention the parameter.------ The declaration------ @--- data WithInt a = WithInt Int a---   deriving 'Generic1'--- @------ yields------ @--- instance 'Generic1' WithInt where---   type 'Rep1' WithInt =---     'D1' ('MetaData \"WithInt\" \"Main\" \"package-name\" 'False)---       ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False)---         ('S1' ('MetaSel 'Nothing---                         'NoSourceUnpackedness---                         'NoSourceStrictness---                         'DecidedLazy)---               ('Rec0' Int)---          ':*:'---          'S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---               'Par1'))--- @------ If the parameter @a@ appears underneath a composition of other type constructors,--- then the representation involves composition, too:------ @--- data Rose a = Fork a [Rose a]--- @------ yields------ @--- instance 'Generic1' Rose where---   type 'Rep1' Rose =---     'D1' ('MetaData \"Rose\" \"Main\" \"package-name\" 'False)---       ('C1' ('MetaCons \"Fork\" 'PrefixI 'False)---         ('S1' ('MetaSel 'Nothing---                         'NoSourceUnpackedness---                         'NoSourceStrictness---                         'DecidedLazy)---               'Par1'---          ':*:'---          'S1' ('MetaSel 'Nothing---                          'NoSourceUnpackedness---                          'NoSourceStrictness---                          'DecidedLazy)---               ([] ':.:' 'Rec1' Rose)))--- @------ where------ @--- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) }--- @---- *** Representation of @k -> *@ types------ |------ The 'Generic1' class can be generalized to range over types of kind--- @k -> *@, for any kind @k@. To do so, derive a 'Generic1' instance with the--- @PolyKinds@ extension enabled. For example, the declaration------ @--- data Proxy (a :: k) = Proxy deriving 'Generic1'--- @------ yields a slightly different instance depending on whether @PolyKinds@ is--- enabled. If compiled without @PolyKinds@, then @'Rep1' Proxy :: * -> *@, but--- if compiled with @PolyKinds@, then @'Rep1' Proxy :: k -> *@.---- *** 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 an unlifted kind, and 'Rec0' expects a type of--- kind @*@.------ 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------ |------ /TODO/------ /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion.----#endif--------------------------------------------------------------------------------  -- * Generic representation types-    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, R-  , D1, C1, S1, D, C, S--  -- * Meta-information-  , Datatype(..), Constructor(..), Selector(..)-  , Fixity(..), FixityI(..), Associativity(..), prec-  , SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..)-  , Meta(..)--  -- * Generic type classes-  , Generic(..), Generic1(..)--  ) where---- We use some base types-import Data.Either ( Either (..) )-import Data.Maybe  ( Maybe(..), fromMaybe )-import Data.Ord    ( Down(..) )-import GHC.Num.Integer ( Integer, integerToInt )-import GHC.Prim    ( Addr#, Char#, Double#, Float#, Int#, Word# )-import GHC.Ptr     ( Ptr )-import GHC.Types---- Needed for instances-import GHC.Ix      ( Ix )-import GHC.Base    ( Alternative(..), Applicative(..), Functor(..)-                   , Monad(..), MonadPlus(..), NonEmpty(..), String, coerce-                   , Semigroup(..), Monoid(..) )-import GHC.Classes ( Eq(..), Ord(..) )-import GHC.Enum    ( Bounded, Enum )-import GHC.Read    ( Read(..) )-import GHC.Show    ( Show(..), showString )-import GHC.Stack.Types ( SrcLoc(..) )-import GHC.Tuple   (Solo (..))-import GHC.Unicode ( GeneralCategory(..) )-import GHC.Fingerprint.Type ( Fingerprint(..) )---- Needed for metadata-import Data.Proxy   ( Proxy(..) )-import GHC.TypeLits ( KnownSymbol, KnownNat, Nat, symbolVal, natVal )------------------------------------------------------------------------------------- Representation types------------------------------------------------------------------------------------- | Void: used for datatypes without constructors-data V1 (p :: k)-  deriving ( Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Read     -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.12.0.0-instance Semigroup (V1 p) where-  v <> _ = v---- | Unit: used for constructors without arguments-data U1 (p :: k) = U1-  deriving ( Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Eq (U1 p) where-  _ == _ = True---- | @since 4.7.0.0-instance Ord (U1 p) where-  compare _ _ = EQ---- | @since 4.9.0.0-deriving instance Read (U1 p)---- | @since 4.9.0.0-instance Show (U1 p) where-  showsPrec _ _ = showString "U1"---- | @since 4.9.0.0-instance Functor U1 where-  fmap _ _ = U1---- | @since 4.9.0.0-instance Applicative U1 where-  pure _ = U1-  _ <*> _ = U1-  liftA2 _ _ _ = U1---- | @since 4.9.0.0-instance Alternative U1 where-  empty = U1-  _ <|> _ = U1---- | @since 4.9.0.0-instance Monad U1 where-  _ >>= _ = U1---- | @since 4.9.0.0-instance MonadPlus U1---- | @since 4.12.0.0-instance Semigroup (U1 p) where-  _ <> _ = U1---- | @since 4.12.0.0-instance Monoid (U1 p) where-  mempty = U1---- | Used for marking occurrences of the parameter-newtype Par1 p = Par1 { unPar1 :: p }-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance Applicative Par1 where-  pure = Par1-  (<*>) = coerce-  liftA2 = coerce---- | @since 4.9.0.0-instance Monad Par1 where-  Par1 x >>= f = f x---- | @since 4.12.0.0-deriving instance Semigroup p => Semigroup (Par1 p)---- | @since 4.12.0.0-deriving instance Monoid p => Monoid (Par1 p)---- | Recursive calls of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@--- is enabled)-newtype Rec1 (f :: k -> Type) (p :: k) = Rec1 { unRec1 :: f p }-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-deriving instance Applicative f => Applicative (Rec1 f)---- | @since 4.9.0.0-deriving instance Alternative f => Alternative (Rec1 f)---- | @since 4.9.0.0-instance Monad f => Monad (Rec1 f) where-  Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a))---- | @since 4.9.0.0-deriving instance MonadPlus f => MonadPlus (Rec1 f)---- | @since 4.12.0.0-deriving instance Semigroup (f p) => Semigroup (Rec1 f p)---- | @since 4.12.0.0-deriving instance Monoid (f p) => Monoid (Rec1 f p)---- | Constants, additional parameters and recursion of kind @*@-newtype K1 (i :: Type) c (p :: k) = K1 { unK1 :: c }-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.12.0.0-instance Monoid c => Applicative (K1 i c) where-  pure _ = K1 mempty-  liftA2 = \_ -> coerce (mappend :: c -> c -> c)-  (<*>) = coerce (mappend :: c -> c -> c)---- | @since 4.12.0.0-deriving instance Semigroup c => Semigroup (K1 i c p)---- | @since 4.12.0.0-deriving instance Monoid c => Monoid (K1 i c p)---- | @since 4.9.0.0-deriving instance Applicative f => Applicative (M1 i c f)---- | @since 4.9.0.0-deriving instance Alternative f => Alternative (M1 i c f)---- | @since 4.9.0.0-deriving instance Monad f => Monad (M1 i c f)---- | @since 4.9.0.0-deriving instance MonadPlus f => MonadPlus (M1 i c f)---- | @since 4.12.0.0-deriving instance Semigroup (f p) => Semigroup (M1 i c f p)---- | @since 4.12.0.0-deriving instance Monoid (f p) => Monoid (M1 i c f p)---- | Meta-information (constructor names, etc.)-newtype M1 (i :: Type) (c :: Meta) (f :: k -> Type) (p :: k) =-    M1 { unM1 :: f p }-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Sums: encode choice between constructors-infixr 5 :+:-data (:+:) (f :: k -> Type) (g :: k -> Type) (p :: k) = L1 (f p) | R1 (g p)-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Products: encode multiple arguments to constructors-infixr 6 :*:-data (:*:) (f :: k -> Type) (g :: k -> Type) (p :: k) = f p :*: g p-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance (Applicative f, Applicative g) => Applicative (f :*: g) where-  pure a = pure a :*: pure a-  (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y)-  liftA2 f (a :*: b) (x :*: y) = liftA2 f a x :*: liftA2 f b y---- | @since 4.9.0.0-instance (Alternative f, Alternative g) => Alternative (f :*: g) where-  empty = empty :*: empty-  (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2)---- | @since 4.9.0.0-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---- | @since 4.9.0.0-instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g)---- | @since 4.12.0.0-instance (Semigroup (f p), Semigroup (g p)) => Semigroup ((f :*: g) p) where-  (x1 :*: y1) <> (x2 :*: y2) = (x1 <> x2) :*: (y1 <> y2)---- | @since 4.12.0.0-instance (Monoid (f p), Monoid (g p)) => Monoid ((f :*: g) p) where-  mempty = mempty :*: mempty---- | Composition of functors-infixr 7 :.:-newtype (:.:) (f :: k2 -> Type) (g :: k1 -> k2) (p :: k1) =-    Comp1 { unComp1 :: f (g p) }-  deriving ( Eq       -- ^ @since 4.7.0.0-           , Ord      -- ^ @since 4.7.0.0-           , Read     -- ^ @since 4.7.0.0-           , Show     -- ^ @since 4.7.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | @since 4.9.0.0-instance (Applicative f, Applicative g) => Applicative (f :.: g) where-  pure x = Comp1 (pure (pure x))-  Comp1 f <*> Comp1 x = Comp1 (liftA2 (<*>) f x)-  liftA2 f (Comp1 x) (Comp1 y) = Comp1 (liftA2 (liftA2 f) x y)---- | @since 4.9.0.0-instance (Alternative f, Applicative g) => Alternative (f :.: g) where-  empty = Comp1 empty-  (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) ::-    forall a . (f :.: g) a -> (f :.: g) a -> (f :.: g) a---- | @since 4.12.0.0-deriving instance Semigroup (f (g p)) => Semigroup ((f :.: g) p)---- | @since 4.12.0.0-deriving instance Monoid (f (g p)) => Monoid ((f :.: g) p)---- | Constants of unlifted kinds------ @since 4.9.0.0-data family URec (a :: Type) (p :: k)---- | Used for marking occurrences of 'Addr#'------ @since 4.9.0.0-data instance URec (Ptr ()) (p :: k) = UAddr { uAddr# :: Addr# }-  deriving ( Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Used for marking occurrences of 'Char#'------ @since 4.9.0.0-data instance URec Char (p :: k) = UChar { uChar# :: Char# }-  deriving ( Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Used for marking occurrences of 'Double#'------ @since 4.9.0.0-data instance URec Double (p :: k) = UDouble { uDouble# :: Double# }-  deriving ( Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Used for marking occurrences of 'Float#'------ @since 4.9.0.0-data instance URec Float (p :: k) = UFloat { uFloat# :: Float# }-  deriving ( Eq, Ord, Show-           , Functor  -- ^ @since 4.9.0.0-           , Generic-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Used for marking occurrences of 'Int#'------ @since 4.9.0.0-data instance URec Int (p :: k) = UInt { uInt# :: Int# }-  deriving ( Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Used for marking occurrences of 'Word#'------ @since 4.9.0.0-data instance URec Word (p :: k) = UWord { uWord# :: Word# }-  deriving ( Eq       -- ^ @since 4.9.0.0-           , Ord      -- ^ @since 4.9.0.0-           , Show     -- ^ @since 4.9.0.0-           , Functor  -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.9.0.0-           , Generic1 -- ^ @since 4.9.0.0-           )---- | Type synonym for @'URec' 'Addr#'@------ @since 4.9.0.0-type UAddr   = URec (Ptr ())--- | Type synonym for @'URec' 'Char#'@------ @since 4.9.0.0-type UChar   = URec Char---- | Type synonym for @'URec' 'Double#'@------ @since 4.9.0.0-type UDouble = URec Double---- | Type synonym for @'URec' 'Float#'@------ @since 4.9.0.0-type UFloat  = URec Float---- | Type synonym for @'URec' 'Int#'@------ @since 4.9.0.0-type UInt    = URec Int---- | Type synonym for @'URec' 'Word#'@------ @since 4.9.0.0-type UWord   = URec Word---- | Tag for K1: recursion (of kind @Type@)-data R---- | Type synonym for encoding recursion (of kind @Type@)-type Rec0  = K1 R---- | Tag for M1: datatype-data D--- | Tag for M1: constructor-data C--- | Tag for M1: record selector-data S---- | Type synonym for encoding meta-information for datatypes-type D1 = M1 D---- | Type synonym for encoding meta-information for constructors-type C1 = M1 C---- | Type synonym for encoding meta-information for record selectors-type S1 = M1 S---- | Class for datatypes that represent datatypes-class Datatype d where-  -- | The name of the datatype (unqualified)-  datatypeName :: t d (f :: k -> Type) (a :: k) -> [Char]-  -- | The fully-qualified name of the module where the type is declared-  moduleName   :: t d (f :: k -> Type) (a :: k) -> [Char]-  -- | The package name of the module where the type is declared-  ---  -- @since 4.9.0.0-  packageName :: t d (f :: k -> Type) (a :: k) -> [Char]-  -- | Marks if the datatype is actually a newtype-  ---  -- @since 4.7.0.0-  isNewtype    :: t d (f :: k -> Type) (a :: k) -> Bool-  isNewtype _ = False---- | @since 4.9.0.0-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-  -- | The name of the constructor-  conName :: t c (f :: k -> Type) (a :: k) -> [Char]--  -- | The fixity of the constructor-  conFixity :: t c (f :: k -> Type) (a :: k) -> Fixity-  conFixity _ = Prefix--  -- | Marks if this constructor is a record-  conIsRecord :: t c (f :: k -> Type) (a :: k) -> Bool-  conIsRecord _ = False---- | @since 4.9.0.0-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       -- ^ @since 4.6.0.0-           , Show     -- ^ @since 4.6.0.0-           , Ord      -- ^ @since 4.6.0.0-           , Read     -- ^ @since 4.6.0.0-           , Generic  -- ^ @since 4.7.0.0-           )---- | This variant of 'Fixity' appears at the type level.------ @since 4.9.0.0-data FixityI = PrefixI | InfixI Associativity Nat---- | Get the precedence of a fixity value.-prec :: Fixity -> Int-prec Prefix      = 10-prec (Infix _ n) = n---- | Datatype to represent the associativity of a constructor-data Associativity = LeftAssociative-                   | RightAssociative-                   | NotAssociative-  deriving ( Eq       -- ^ @since 4.6.0.0-           , Show     -- ^ @since 4.6.0.0-           , Ord      -- ^ @since 4.6.0.0-           , Read     -- ^ @since 4.6.0.0-           , Enum     -- ^ @since 4.9.0.0-           , Bounded  -- ^ @since 4.9.0.0-           , Ix       -- ^ @since 4.9.0.0-           , Generic  -- ^ @since 4.7.0.0-           )---- | The unpackedness of a field as the user wrote it in the source code. For--- example, in the following data type:------ @--- data E = ExampleConstructor     Int---            {\-\# NOUNPACK \#-\} Int---            {\-\#   UNPACK \#-\} Int--- @------ The fields of @ExampleConstructor@ have 'NoSourceUnpackedness',--- 'SourceNoUnpack', and 'SourceUnpack', respectively.------ @since 4.9.0.0-data SourceUnpackedness = NoSourceUnpackedness-                        | SourceNoUnpack-                        | SourceUnpack-  deriving ( Eq      -- ^ @since 4.9.0.0-           , Show    -- ^ @since 4.9.0.0-           , Ord     -- ^ @since 4.9.0.0-           , Read    -- ^ @since 4.9.0.0-           , Enum    -- ^ @since 4.9.0.0-           , Bounded -- ^ @since 4.9.0.0-           , Ix      -- ^ @since 4.9.0.0-           , Generic -- ^ @since 4.9.0.0-           )---- | The strictness of a field as the user wrote it in the source code. For--- example, in the following data type:------ @--- data E = ExampleConstructor Int ~Int !Int--- @------ The fields of @ExampleConstructor@ have 'NoSourceStrictness',--- 'SourceLazy', and 'SourceStrict', respectively.------ @since 4.9.0.0-data SourceStrictness = NoSourceStrictness-                      | SourceLazy-                      | SourceStrict-  deriving ( Eq      -- ^ @since 4.9.0.0-           , Show    -- ^ @since 4.9.0.0-           , Ord     -- ^ @since 4.9.0.0-           , Read    -- ^ @since 4.9.0.0-           , Enum    -- ^ @since 4.9.0.0-           , Bounded -- ^ @since 4.9.0.0-           , Ix      -- ^ @since 4.9.0.0-           , Generic -- ^ @since 4.9.0.0-           )---- | The strictness that GHC infers for a field during compilation. Whereas--- there are nine different combinations of 'SourceUnpackedness' and--- '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.------ @since 4.9.0.0-data DecidedStrictness = DecidedLazy-                       | DecidedStrict-                       | DecidedUnpack-  deriving ( Eq      -- ^ @since 4.9.0.0-           , Show    -- ^ @since 4.9.0.0-           , Ord     -- ^ @since 4.9.0.0-           , Read    -- ^ @since 4.9.0.0-           , Enum    -- ^ @since 4.9.0.0-           , Bounded -- ^ @since 4.9.0.0-           , Ix      -- ^ @since 4.9.0.0-           , Generic -- ^ @since 4.9.0.0-           )---- | Class for datatypes that represent records-class Selector s where-  -- | The name of the selector-  selName :: t s (f :: k -> Type) (a :: k) -> [Char]-  -- | The selector's unpackedness annotation (if any)-  ---  -- @since 4.9.0.0-  selSourceUnpackedness :: t s (f :: k -> Type) (a :: k) -> SourceUnpackedness-  -- | The selector's strictness annotation (if any)-  ---  -- @since 4.9.0.0-  selSourceStrictness :: t s (f :: k -> Type) (a :: k) -> SourceStrictness-  -- | The strictness that the compiler inferred for the selector-  ---  -- @since 4.9.0.0-  selDecidedStrictness :: t s (f :: k -> Type) (a :: k) -> DecidedStrictness---- | @since 4.9.0.0-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.------ A 'Generic' instance must satisfy the following laws:------ @--- 'from' . 'to' ≡ 'Prelude.id'--- 'to' . 'from' ≡ 'Prelude.id'--- @-class Generic a where-  -- | Generic representation type-  type Rep a :: Type -> Type-  -- | Convert from the datatype to its representation-  from  :: a -> (Rep a) x-  -- | Convert from the representation to the datatype-  to    :: (Rep a) x -> a----- | Representable types of kind @* -> *@ (or kind @k -> *@, when @PolyKinds@--- is enabled).--- This class is derivable in GHC with the @DeriveGeneric@ flag on.------ A 'Generic1' instance must satisfy the following laws:------ @--- 'from1' . 'to1' ≡ 'Prelude.id'--- 'to1' . 'from1' ≡ 'Prelude.id'--- @-class Generic1 (f :: k -> Type) where-  -- | Generic representation type-  type Rep1 f :: k -> Type-  -- | Convert from the datatype to its representation-  from1  :: f a -> (Rep1 f) a-  -- | Convert from the representation to the datatype-  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 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.------ @since 4.9.0.0-data Meta = MetaData Symbol Symbol Symbol Bool-          | MetaCons Symbol FixityI Bool-          | MetaSel  (Maybe Symbol)-                     SourceUnpackedness SourceStrictness DecidedStrictness------------------------------------------------------------------------------------- Derived instances------------------------------------------------------------------------------------- | @since 4.6.0.0-deriving instance Generic [a]---- | @since 4.6.0.0-deriving instance Generic (NonEmpty a)---- | @since 4.6.0.0-deriving instance Generic (Maybe a)---- | @since 4.6.0.0-deriving instance Generic (Either a b)---- | @since 4.6.0.0-deriving instance Generic Bool---- | @since 4.6.0.0-deriving instance Generic Ordering---- | @since 4.6.0.0-deriving instance Generic (Proxy t)---- | @since 4.6.0.0-deriving instance Generic ()---- | @since 4.15-deriving instance Generic (Solo a)---- | @since 4.6.0.0-deriving instance Generic ((,) a b)---- | @since 4.6.0.0-deriving instance Generic ((,,) a b c)---- | @since 4.6.0.0-deriving instance Generic ((,,,) a b c d)---- | @since 4.6.0.0-deriving instance Generic ((,,,,) a b c d e)---- | @since 4.6.0.0-deriving instance Generic ((,,,,,) a b c d e f)---- | @since 4.6.0.0-deriving instance Generic ((,,,,,,) a b c d e f g)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,) a b c d e f g h)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,) a b c d e f g h i)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n)---- | @since 4.16.0.0-deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o)---- | @since 4.12.0.0-deriving instance Generic (Down a)---- | @since 4.15.0.0-deriving instance Generic SrcLoc---- | @since 4.15.0.0-deriving instance Generic GeneralCategory---- | @since 4.15.0.0-deriving instance Generic Fingerprint---- | @since 4.6.0.0-deriving instance Generic1 []---- | @since 4.6.0.0-deriving instance Generic1 NonEmpty---- | @since 4.6.0.0-deriving instance Generic1 Maybe---- | @since 4.6.0.0-deriving instance Generic1 (Either a)---- | @since 4.6.0.0-deriving instance Generic1 Proxy---- | @since 4.15-deriving instance Generic1 Solo---- | @since 4.6.0.0-deriving instance Generic1 ((,) a)---- | @since 4.6.0.0-deriving instance Generic1 ((,,) a b)---- | @since 4.6.0.0-deriving instance Generic1 ((,,,) a b c)---- | @since 4.6.0.0-deriving instance Generic1 ((,,,,) a b c d)---- | @since 4.6.0.0-deriving instance Generic1 ((,,,,,) a b c d e)---- | @since 4.6.0.0-deriving instance Generic1 ((,,,,,,) a b c d e f)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,) a b c d e f g)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,) a b c d e f g h)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m)---- | @since 4.16.0.0-deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n)---- | @since 4.12.0.0-deriving instance Generic1 Down------------------------------------------------------------------------------------- Copied from the singletons package------------------------------------------------------------------------------------- | The singleton kind-indexed data family.-data family Sing (a :: k)---- | A 'SingI' constraint is essentially an implicitly-passed singleton.-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---- | 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 SingKind k where-  -- | Get a base type from a proxy for the promoted kind. For example,-  -- @DemoteRep Bool@ will be the type @Bool@.-  type DemoteRep k :: Type--  -- | Convert a singleton to its unrefined version.-  fromSing :: Sing (a :: k) -> DemoteRep k---- Singleton symbols-data instance Sing (s :: Symbol) where-  SSym :: KnownSymbol s => Sing s---- | @since 4.9.0.0-instance KnownSymbol a => SingI a where sing = SSym---- | @since 4.9.0.0-instance SingKind Symbol where-  type DemoteRep Symbol = String-  fromSing (SSym :: Sing s) = symbolVal (Proxy :: Proxy s)---- Singleton booleans-data instance Sing (a :: Bool) where-  STrue  :: Sing 'True-  SFalse :: Sing 'False---- | @since 4.9.0.0-instance SingI 'True  where sing = STrue---- | @since 4.9.0.0-instance SingI 'False where sing = SFalse---- | @since 4.9.0.0-instance SingKind Bool where-  type DemoteRep Bool = Bool-  fromSing STrue  = True-  fromSing SFalse = False---- Singleton Maybe-data instance Sing (b :: Maybe a) where-  SNothing :: Sing 'Nothing-  SJust    :: Sing a -> Sing ('Just a)---- | @since 4.9.0.0-instance            SingI 'Nothing  where sing = SNothing---- | @since 4.9.0.0-instance SingI a => SingI ('Just a) where sing = SJust sing---- | @since 4.9.0.0-instance SingKind a => SingKind (Maybe a) where-  type DemoteRep (Maybe a) = Maybe (DemoteRep a)-  fromSing SNothing  = Nothing-  fromSing (SJust a) = Just (fromSing a)---- Singleton Fixity-data instance Sing (a :: FixityI) where-  SPrefix :: Sing 'PrefixI-  SInfix  :: Sing a -> Integer -> Sing ('InfixI a n)---- | @since 4.9.0.0-instance SingI 'PrefixI where sing = SPrefix---- | @since 4.9.0.0-instance (SingI a, KnownNat n) => SingI ('InfixI a n) where-  sing = SInfix (sing :: Sing a) (natVal (Proxy :: Proxy n))---- | @since 4.9.0.0-instance SingKind FixityI where-  type DemoteRep FixityI = Fixity-  fromSing SPrefix      = Prefix-  fromSing (SInfix a n) = Infix (fromSing a) (integerToInt n)---- Singleton Associativity-data instance Sing (a :: Associativity) where-  SLeftAssociative  :: Sing 'LeftAssociative-  SRightAssociative :: Sing 'RightAssociative-  SNotAssociative   :: Sing 'NotAssociative---- | @since 4.9.0.0-instance SingI 'LeftAssociative  where sing = SLeftAssociative---- | @since 4.9.0.0-instance SingI 'RightAssociative where sing = SRightAssociative---- | @since 4.9.0.0-instance SingI 'NotAssociative   where sing = SNotAssociative---- | @since 4.0.0.0-instance SingKind Associativity where-  type DemoteRep Associativity = Associativity-  fromSing SLeftAssociative  = LeftAssociative-  fromSing SRightAssociative = RightAssociative-  fromSing SNotAssociative   = NotAssociative---- Singleton SourceUnpackedness-data instance Sing (a :: SourceUnpackedness) where-  SNoSourceUnpackedness :: Sing 'NoSourceUnpackedness-  SSourceNoUnpack       :: Sing 'SourceNoUnpack-  SSourceUnpack         :: Sing 'SourceUnpack---- | @since 4.9.0.0-instance SingI 'NoSourceUnpackedness where sing = SNoSourceUnpackedness---- | @since 4.9.0.0-instance SingI 'SourceNoUnpack       where sing = SSourceNoUnpack---- | @since 4.9.0.0-instance SingI 'SourceUnpack         where sing = SSourceUnpack---- | @since 4.9.0.0-instance SingKind SourceUnpackedness where-  type DemoteRep 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---- | @since 4.9.0.0-instance SingI 'NoSourceStrictness where sing = SNoSourceStrictness---- | @since 4.9.0.0-instance SingI 'SourceLazy         where sing = SSourceLazy---- | @since 4.9.0.0-instance SingI 'SourceStrict       where sing = SSourceStrict---- | @since 4.9.0.0-instance SingKind SourceStrictness where-  type DemoteRep 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---- | @since 4.9.0.0-instance SingI 'DecidedLazy   where sing = SDecidedLazy---- | @since 4.9.0.0-instance SingI 'DecidedStrict where sing = SDecidedStrict---- | @since 4.9.0.0-instance SingI 'DecidedUnpack where sing = SDecidedUnpack---- | @since 4.9.0.0-instance SingKind DecidedStrictness where-  type DemoteRep DecidedStrictness = DecidedStrictness-  fromSing SDecidedLazy   = DecidedLazy-  fromSing SDecidedStrict = DecidedStrict-  fromSing SDecidedUnpack = DecidedUnpack
− GHC/IO.hs 
@@ -1,462 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude-           , BangPatterns-           , RankNTypes-           , MagicHash-           , ScopedTypeVariables-           , UnboxedTuples-  #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO--- 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)------ Definitions for the 'IO' monad and its friends.-----------------------------------------------------------------------------------module GHC.IO (-        IO(..), unIO, liftIO, mplusIO,-        unsafePerformIO, unsafeInterleaveIO,-        unsafeDupablePerformIO, unsafeDupableInterleaveIO,-        noDuplicate,--        -- To and from ST-        stToIO, ioToST, unsafeIOToST, unsafeSTToIO,--        FilePath,--        catch, catchException, catchAny, throwIO,-        mask, mask_, uninterruptibleMask, uninterruptibleMask_,-        MaskingState(..), getMaskingState,-        unsafeUnmask, interruptible,-        onException, bracket, finally, evaluate,-        mkUserError-    ) where--import GHC.Base-import GHC.ST-import GHC.Exception-import GHC.Show-import GHC.IO.Unsafe-import Unsafe.Coerce ( unsafeCoerce )--import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )---- ------------------------------------------------------------------------------ The IO Monad--{--The IO Monad is just an instance of the ST monad, where the state thread-is the real world.  We use the exception mechanism (in GHC.Exception) to-implement IO exceptions.--NOTE: The IO representation is deeply wired in to various parts of the-system.  The following list may or may not be exhaustive:--Compiler  - types of various primitives in GHC.Builtin.PrimOps--RTS       - forceIO (StgStartup.cmm)-          - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast-            (Exception.cmm)-          - raiseAsync (RaiseAsync.c)--Prelude   - GHC.IO.hs, and several other places including-            GHC.Exception.hs.--Libraries - parts of hslibs/lang.----SDM--}--liftIO :: IO a -> State# RealWorld -> STret RealWorld a-liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r---- ------------------------------------------------------------------------------ Coercions between IO and ST---- | Embed a strict state thread in an 'IO'--- action.  The 'RealWorld' parameter indicates that the internal state--- used by the 'ST' computation is a special one supplied by the 'IO'--- monad, and thus distinct from those used by invocations of 'runST'.-stToIO        :: ST RealWorld a -> IO a-stToIO (ST m) = IO m---- | Convert an 'IO' action into an 'ST' action. The type of the result--- is constrained to use a 'RealWorld' state thread, and therefore the--- result cannot be passed to 'runST'.-ioToST        :: IO a -> ST RealWorld a-ioToST (IO m) = (ST m)---- | Convert an 'IO' action to an 'ST' action.--- This relies on 'IO' and 'ST' having the same representation modulo the--- constraint on the state thread type parameter.-unsafeIOToST        :: IO a -> ST s a-unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce io) s---- | Convert an 'ST' action to an 'IO' action.--- This relies on 'IO' and 'ST' having the same representation modulo the--- constraint on the state thread type parameter.------ For an example demonstrating why this is unsafe, see--- https://mail.haskell.org/pipermail/haskell-cafe/2009-April/060719.html-unsafeSTToIO :: ST s a -> IO a-unsafeSTToIO (ST m) = IO (unsafeCoerce m)---- -------------------------------------------------------------------------------- | File and directory names are values of type 'String', whose precise--- meaning is operating system dependent. Files can be opened, yielding a--- handle which can then be used to operate on the contents of that file.--type FilePath = String---- -------------------------------------------------------------------------------- Primitive catch and throwIO--{--catchException/catch used to handle the passing around of the state to the-action and the handler.  This turned out to be a bad idea - it meant-that we had to wrap both arguments in thunks so they could be entered-as normal (remember IO returns an unboxed pair...).--Now catch# has type--    catch# :: IO a -> (b -> IO a) -> IO a--(well almost; the compiler doesn't know about the IO newtype so we-have to work around that in the definition of catch 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 handler = catch io handler---- | This is the simplest of the exception-catching functions.  It--- takes a single argument, runs it, and if an exception is raised--- the \"handler\" is executed, with the value of the exception passed as an--- argument.  Otherwise, the result is returned as normal.  For example:------ >   catch (readFile f)--- >         (\e -> do let err = show (e :: IOException)--- >                   hPutStr stderr ("Warning: Couldn't open " ++ f ++ ": " ++ err)--- >                   return "")------ Note that we have to give a type signature to @e@, or the program--- will not typecheck as the type is ambiguous. While it is possible--- to catch exceptions of any type, see the section \"Catching all--- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so.------ For catching exceptions in pure (non-'IO') expressions, see the--- function 'evaluate'.------ Note that due to Haskell\'s unspecified evaluation order, an--- expression may throw one of several possible exceptions: consider--- the expression @(error \"urk\") + (1 \`div\` 0)@.  Does--- the expression throw--- @ErrorCall \"urk\"@, or @DivideByZero@?------ The answer is \"it might throw either\"; the choice is--- non-deterministic. If you are catching any type of exception then you--- might catch either. If you are calling @catch@ with type--- @IO Int -> (ArithException -> IO Int) -> IO Int@ then the handler may--- get run with @DivideByZero@ as an argument, or an @ErrorCall \"urk\"@--- exception may be propagated further up. If you call it again, you--- might get the opposite behaviour. This is ok, because 'catch' is an--- 'IO' computation.----catch   :: Exception e-        => IO a         -- ^ The computation to run-        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised-        -> IO a--- See #exceptions_and_strictness#.-catch (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,--- @catchAny 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)---- Using catchException here means that if `m` throws an--- 'IOError' /as an imprecise exception/, we will not catch--- it. No one should really be doing that anyway.-mplusIO :: IO a -> IO a -> IO a-mplusIO m n = m `catchException` \ (_ :: IOError) -> n---- | 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--- two functions are subtly different:------ > throw e   `seq` x  ===> throw e--- > throwIO e `seq` x  ===> x------ The first example will cause the exception @e@ to be raised,--- whereas the second one won\'t.  In fact, 'throwIO' will only cause--- an exception to be raised when it is used within the 'IO' monad.--- The 'throwIO' variant should be used in preference to 'throw' to--- raise an exception within the 'IO' monad because it guarantees--- ordering with respect to other 'IO' operations, whereas 'throw'--- does not.-throwIO :: Exception e => e -> IO a-throwIO e = IO (raiseIO# (toException e))---- -------------------------------------------------------------------------------- Controlling asynchronous exception delivery---- Applying 'block' to a computation will--- execute that computation with asynchronous exceptions--- /blocked/.  That is, any thread which--- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be--- blocked until asynchronous exceptions are unblocked again.  There\'s--- no need to worry about re-enabling asynchronous exceptions; that is--- done automatically on exiting the scope of--- 'block'.------ Threads created by 'Control.Concurrent.forkIO' inherit the blocked--- state from the parent; that is, to start a thread in blocked mode,--- use @block $ forkIO ...@.  This is particularly useful if you need to--- establish an exception handler in the forked thread before any--- asynchronous exceptions are received.-block :: IO a -> IO a-block (IO io) = IO $ maskAsyncExceptions# io---- To re-enable asynchronous exceptions inside the scope of--- 'block', 'unblock' can be--- used.  It scopes in exactly the same way, so on exit from--- 'unblock' asynchronous exception delivery will--- be disabled again.-unblock :: IO a -> IO a-unblock = unsafeUnmask--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---- | Describes the behaviour of a thread when an asynchronous--- exception is received.-data MaskingState-  = Unmasked -- ^ asynchronous exceptions are unmasked (the normal state)-  | MaskedInterruptible-      -- ^ the state during 'mask': asynchronous exceptions are masked, but blocking operations may still be interrupted-  | MaskedUninterruptible-      -- ^ the state during 'uninterruptibleMask': asynchronous exceptions are masked, and blocking operations may not be interrupted- deriving ( Eq   -- ^ @since 4.3.0.0-          , Show -- ^ @since 4.3.0.0-          )---- | Returns the 'MaskingState' for the current thread.-getMaskingState :: IO MaskingState-getMaskingState  = IO $ \s ->-  case getMaskingState# s of-     (# s', i #) -> (# s', case i of-                             0# -> Unmasked-                             1# -> MaskedUninterruptible-                             _  -> MaskedInterruptible #)--onException :: IO a -> IO b -> IO a-onException io what = io `catchException` \e -> do _ <- what-                                                   throwIO (e :: SomeException)---- | Executes an IO computation with asynchronous--- exceptions /masked/.  That is, any thread which attempts to raise--- an exception in the current thread with 'Control.Exception.throwTo'--- will be blocked until asynchronous exceptions are unmasked again.------ The argument passed to 'mask' is a function that takes as its--- argument another function, which can be used to restore the--- prevailing masking state within the context of the masked--- computation.  For example, a common way to use 'mask' is to protect--- the acquisition of a resource:------ > mask $ \restore -> do--- >     x <- acquire--- >     restore (do_something_with x) `onException` release--- >     release------ This code guarantees that @acquire@ is paired with @release@, by masking--- asynchronous exceptions for the critical parts. (Rather than write--- this code yourself, it would be better to use--- 'Control.Exception.bracket' which abstracts the general pattern).------ Note that the @restore@ action passed to the argument to 'mask'--- does not necessarily unmask asynchronous exceptions, it just--- restores the masking state to that of the enclosing context.  Thus--- if asynchronous exceptions are already masked, 'mask' cannot be used--- to unmask exceptions again.  This is so that if you call a library function--- with exceptions masked, you can be sure that the library call will not be--- able to unmask exceptions again.  If you are writing library code and need--- to use asynchronous exceptions, the only way is to create a new thread;--- see 'Control.Concurrent.forkIOWithUnmask'.------ Asynchronous exceptions may still be received while in the masked--- state if the masked thread /blocks/ in certain ways; see--- "Control.Exception#interruptible".------ Threads created by 'Control.Concurrent.forkIO' inherit the--- 'MaskingState' from the parent; that is, to start a thread in the--- 'MaskedInterruptible' state,--- use @mask_ $ forkIO ...@.  This is particularly useful if you need--- to establish an exception handler in the forked thread before any--- asynchronous exceptions are received.  To create a new thread in--- an unmasked state use 'Control.Concurrent.forkIOWithUnmask'.----mask  :: ((forall a. IO a -> IO a) -> IO b) -> IO b---- | Like 'mask', but does not pass a @restore@ action to the argument.-mask_ :: IO a -> IO a---- | Like 'mask', but the masked computation is not interruptible (see--- "Control.Exception#interruptible").  THIS SHOULD BE USED WITH--- GREAT CARE, because if a thread executing in 'uninterruptibleMask'--- blocks for any reason, then the thread (and possibly the program,--- if this is the main thread) will be unresponsive and unkillable.--- This function should only be necessary if you need to mask--- exceptions around an interruptible operation, and you can guarantee--- that the interruptible operation will only block for a short period--- of time.----uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b---- | Like 'uninterruptibleMask', but does not pass a @restore@ action--- to the argument.-uninterruptibleMask_ :: IO a -> IO a--mask_ io = mask $ \_ -> io--mask io = do-  b <- getMaskingState-  case b of-    Unmasked              -> block $ io unblock-    MaskedInterruptible   -> io block-    MaskedUninterruptible -> io blockUninterruptible--uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io--uninterruptibleMask io = do-  b <- getMaskingState-  case b of-    Unmasked              -> blockUninterruptible $ io unblock-    MaskedInterruptible   -> blockUninterruptible $ io block-    MaskedUninterruptible -> io blockUninterruptible--bracket-        :: IO a         -- ^ computation to run first (\"acquire resource\")-        -> (a -> IO b)  -- ^ computation to run last (\"release resource\")-        -> (a -> IO c)  -- ^ computation to run in-between-        -> IO c         -- returns the value from the in-between computation-bracket before after thing =-  mask $ \restore -> do-    a <- before-    r <- restore (thing a) `onException` after a-    _ <- after a-    return r--finally :: IO a         -- ^ computation to run first-        -> IO b         -- ^ computation to run afterward (even if an exception-                        -- was raised)-        -> IO a         -- returns the value from the first computation-a `finally` sequel =-  mask $ \restore -> do-    r <- restore a `onException` sequel-    _ <- sequel-    return r---- | Evaluate the argument to weak head normal form.------ 'evaluate' is typically used to uncover any exceptions that a lazy value--- may contain, and possibly handle them.------ 'evaluate' only evaluates to /weak head normal form/. If deeper--- evaluation is needed, the @force@ function from @Control.DeepSeq@--- may be handy:------ > 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 #11555 and #13330). 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 @test1@ will print "it failed", @test2@ will print "uh oh".--When using 'catchException', exceptions thrown while evaluating the-action-to-be-executed will 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"-use 'catch' rather than 'catchException'.--}---- For SOURCE import by GHC.Base to define failIO.-mkUserError       :: [Char]  -> SomeException-mkUserError str   = toException (userError str)
− GHC/IO.hs-boot 
@@ -1,10 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO where--import GHC.Types-import {-# SOURCE #-} GHC.Exception.Type (SomeException)--mplusIO :: IO a -> IO a -> IO a-mkUserError :: [Char] -> SomeException
− GHC/IO/Buffer.hs 
@@ -1,335 +0,0 @@-{-# LANGUAGE Trustworthy, BangPatterns #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Buffer--- Copyright   :  (c) The University of Glasgow 2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Buffers used in the IO system-----------------------------------------------------------------------------------module GHC.IO.Buffer (-    -- * Buffers of any element-    Buffer(..), BufferState(..), CharBuffer, CharBufElem,--    -- ** Creation-    newByteBuffer,-    newCharBuffer,-    newBuffer,-    emptyBuffer,--    -- ** Insertion/removal-    bufferRemove,-    bufferAdd,-    slideContents,-    bufferAdjustL,-    bufferAddOffset,-    bufferAdjustOffset,--    -- ** Inspecting-    isEmptyBuffer,-    isFullBuffer,-    isFullCharBuffer,-    isWriteBuffer,-    bufferElems,-    bufferAvailable,-    bufferOffset,-    summaryBuffer,--    -- ** Operating on the raw buffer as a Ptr-    withBuffer,-    withRawBuffer,--    -- ** Assertions-    checkBuffer,--    -- * Raw buffers-    RawBuffer,-    readWord8Buf,-    writeWord8Buf,-    RawCharBuffer,-    peekCharBuf,-    readCharBuf,-    writeCharBuf,-    readCharBufPtr,-    writeCharBufPtr,-    charSize,- ) where--import GHC.Base--- import GHC.IO-import GHC.Num-import GHC.Ptr-import GHC.Word-import GHC.Show-import GHC.Real-import GHC.List-import GHC.ForeignPtr  (unsafeWithForeignPtr)-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Storable---- Char buffers use either UTF-16 or UTF-32, with the endianness matching--- the endianness of the host.------ Invariants:---   * a Char buffer consists of *valid* UTF-16 or UTF-32---   * only whole characters: no partial surrogate pairs--#define CHARBUF_UTF32---- #define CHARBUF_UTF16------ NB. it won't work to just change this to CHARBUF_UTF16.  Some of--- the code to make this work is there, and it has been tested with--- the Iconv codec, but there are some pieces that are known to be--- broken.  In particular, the built-in codecs--- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or--- similar in place of the ow >= os comparisons.------ Tamar: We need to do this eventually for Windows, as we have to re-encode--- the text as UTF-16 anyway, so if we can avoid it it would be great.---- ------------------------------------------------------------------------------ Raw blocks of data--type RawBuffer e = ForeignPtr e--readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8-readWord8Buf fp ix = unsafeWithForeignPtr fp $ \p -> peekByteOff p ix--writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()-writeWord8Buf fp ix w = unsafeWithForeignPtr fp $ \p -> pokeByteOff p ix w--#if defined(CHARBUF_UTF16)-type CharBufElem = Word16-#else-type CharBufElem = Char-#endif--type RawCharBuffer = RawBuffer CharBufElem--peekCharBuf :: RawCharBuffer -> Int -> IO Char-peekCharBuf arr ix = unsafeWithForeignPtr arr $ \p -> do-                        (c,_) <- readCharBufPtr p ix-                        return c--{-# INLINE readCharBuf #-}-readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)-readCharBuf arr ix = unsafeWithForeignPtr arr $ \p -> readCharBufPtr p ix--{-# INLINE writeCharBuf #-}-writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int-writeCharBuf arr ix c = unsafeWithForeignPtr arr $ \p -> writeCharBufPtr p ix c--{-# INLINE readCharBufPtr #-}-readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)-#if defined(CHARBUF_UTF16)-readCharBufPtr p ix = do-  c1 <- peekElemOff p ix-  if (c1 < 0xd800 || c1 > 0xdbff)-     then return (chr (fromIntegral c1), ix+1)-     else do c2 <- peekElemOff p (ix+1)-             return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +-                                (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)-#else-readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)-#endif--{-# INLINE writeCharBufPtr #-}-writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int-#if defined(CHARBUF_UTF16)-writeCharBufPtr p ix ch-  | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)-                     return (ix+1)-  | otherwise   = do let c' = c - 0x10000-                     pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))-                     pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))-                     return (ix+2)-  where-    c = ord ch-#else-writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)-#endif--charSize :: Int-#if defined(CHARBUF_UTF16)-charSize = 2-#else-charSize = 4-#endif---- ------------------------------------------------------------------------------ Buffers---- | A mutable array of bytes that can be passed to foreign functions.------ The buffer is represented by a record, where the record contains--- the raw buffer and the start/end points of the filled portion.  The--- buffer contents itself is mutable, but the rest of the record is--- immutable.  This is a slightly odd mix, but it turns out to be--- quite practical: by making all the buffer metadata immutable, we--- can have operations on buffer metadata outside of the IO monad.------ The "live" elements of the buffer are those between the 'bufL' and--- 'bufR' offsets.  In an empty buffer, 'bufL' is equal to 'bufR', but--- they might not be zero: for example, the buffer might correspond to--- a memory-mapped file and in which case 'bufL' will point to the--- next location to be written, which is not necessarily the beginning--- of the file.------ On Posix systems the I/O manager has an implicit reliance on doing a file--- read moving the file pointer.  However on Windows async operations the kernel--- object representing a file does not use the file pointer offset.  Logically--- this makes sense since operations can be performed in any arbitrary order.--- OVERLAPPED operations don't respect the file pointer offset as their--- intention is to support arbitrary async reads to anywhere at a much lower--- level.  As such we should explicitly keep track of the file offsets of the--- target in the buffer.  Any operation to seek should also update this entry.------ In order to keep us sane we try to uphold the invariant that any function--- being passed a Handle is responsible for updating the handles offset unless--- other behaviour is documented.-data Buffer e-  = Buffer {-        bufRaw    :: !(RawBuffer e),-        bufState  :: BufferState,-        bufSize   :: !Int,          -- in elements, not bytes-        bufOffset :: !Word64,       -- start location for next read/write-        bufL      :: !Int,          -- offset of first item in the buffer-        bufR      :: !Int           -- offset of last item + 1-  }--#if defined(CHARBUF_UTF16)-type CharBuffer = Buffer Word16-#else-type CharBuffer = Buffer Char-#endif--data BufferState = ReadBuffer | WriteBuffer-  deriving Eq -- ^ @since 4.2.0.0--withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a-withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f--withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a-withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f--isEmptyBuffer :: Buffer e -> Bool-isEmptyBuffer Buffer{ bufL=l, bufR=r } = l == r--isFullBuffer :: Buffer e -> Bool-isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w---- if a Char buffer does not have room for a surrogate pair, it is "full"-isFullCharBuffer :: Buffer e -> Bool-#if defined(CHARBUF_UTF16)-isFullCharBuffer buf = bufferAvailable buf < 2-#else-isFullCharBuffer = isFullBuffer-#endif--isWriteBuffer :: Buffer e -> Bool-isWriteBuffer buf = case bufState buf of-                        WriteBuffer -> True-                        ReadBuffer  -> False--bufferElems :: Buffer e -> Int-bufferElems Buffer{ bufR=w, bufL=r } = w - r--bufferAvailable :: Buffer e -> Int-bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w--bufferRemove :: Int -> Buffer e -> Buffer e-bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf--bufferAdjustL :: Int -> Buffer e -> Buffer e-bufferAdjustL l buf@Buffer{ bufR=w }-  | l == w    = buf{ bufL=0, bufR=0 }-  | otherwise = buf{ bufL=l, bufR=w }--bufferAdd :: Int -> Buffer e -> Buffer e-bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }--bufferOffset :: Buffer e -> Word64-bufferOffset Buffer{ bufOffset=off } = off--bufferAdjustOffset :: Word64 -> Buffer e -> Buffer e-bufferAdjustOffset offs buf = buf{ bufOffset=offs }---- The adjustment to the offset can be 32bit int on 32 platforms.--- This is fine, we only use this after reading into/writing from--- the buffer so we will never overflow here.-bufferAddOffset :: Int -> Buffer e -> Buffer e-bufferAddOffset offs buf@Buffer{ bufOffset=w } =-  buf{ bufOffset=w+(fromIntegral offs) }--emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e-emptyBuffer raw sz state =-  Buffer{ bufRaw=raw, bufState=state, bufOffset=0, bufR=0, bufL=0, bufSize=sz }--newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)-newByteBuffer c st = newBuffer c c st--newCharBuffer :: Int -> BufferState -> IO CharBuffer-newCharBuffer c st = newBuffer (c * charSize) c st--newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)-newBuffer bytes sz state = do-  fp <- mallocForeignPtrBytes bytes-  return (emptyBuffer fp sz state)---- | slides the contents of the buffer to the beginning-slideContents :: Buffer Word8 -> IO (Buffer Word8)-slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do-  let elems = r - l-  withRawBuffer raw $ \p ->-      do _ <- memmove p (p `plusPtr` l) (fromIntegral elems)-         return ()-  return buf{ bufL=0, bufR=elems }--foreign import ccall unsafe "memmove"-   memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)--summaryBuffer :: Buffer a -> String-summaryBuffer !buf  -- Strict => slightly better code-   = ppr (show $ bufRaw buf) ++ "@buf" ++ show (bufSize buf)-   ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"-   ++ " (>=" ++ show (bufOffset buf) ++ ")"-  where ppr :: String -> String-        ppr ('0':'x':xs) = let p = dropWhile (=='0') xs-                           in if null p then "0x0" else '0':'x':p-        ppr x = x---- Note [INVARIANTS on Buffers]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~---   * r <= w---   * if r == w, and the buffer is for reading, then r == 0 && w == 0---   * a write buffer is never full.  If an operation---     fills up the buffer, it will always flush it before---     returning.---   * a read buffer may be full as a result of hLookAhead.  In normal---     operation, a read buffer always has at least one character of space.--checkBuffer :: Buffer a -> IO ()-checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } =-     check buf (-        size > 0-        && r <= w-        && w <= size-        && ( r /= w || state == WriteBuffer || (r == 0 && w == 0) )-        && ( state /= WriteBuffer || w < size ) -- write buffer is never full-      )--check :: Buffer a -> Bool -> IO ()-check _   True  = return ()-check buf False = errorWithoutStackTrace ("buffer invariant violation: " ++ summaryBuffer buf)-
− GHC/IO/BufferedIO.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.BufferedIO--- Copyright   :  (c) The University of Glasgow 2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Class of buffered IO devices-----------------------------------------------------------------------------------module GHC.IO.BufferedIO (-        BufferedIO(..),-        readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking-    ) where--import GHC.Base-import GHC.Ptr-import Data.Word-import GHC.Num-import GHC.IO.Device as IODevice-import GHC.IO.Device as RawIO-import GHC.IO.Buffer---- | The purpose of 'BufferedIO' is to provide a common interface for I/O--- devices that can read and write data through a buffer.  Devices that--- implement 'BufferedIO' include ordinary files, memory-mapped files,--- and bytestrings.  The underlying device implementing a 'System.IO.Handle'--- must provide 'BufferedIO'.----class BufferedIO dev where-  -- | allocate a new buffer.  The size of the buffer is at the-  -- discretion of the device; e.g. for a memory-mapped file the-  -- buffer will probably cover the entire file.-  newBuffer         :: dev -> BufferState -> IO (Buffer Word8)--  -- | reads bytes into the buffer, blocking if there are no bytes-  -- available.  Returns the number of bytes read (zero indicates-  -- end-of-file), and the new buffer.-  fillReadBuffer    :: dev -> Buffer Word8 -> IO (Int, Buffer Word8)--  -- | reads bytes into the buffer without blocking.  Returns the-  -- number of bytes read (Nothing indicates end-of-file), and the new-  -- buffer.-  fillReadBuffer0   :: dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8)--  -- | Prepares an empty write buffer.  This lets the device decide-  -- how to set up a write buffer: the buffer may need to point to a-  -- specific location in memory, for example.  This is typically used-  -- by the client when switching from reading to writing on a-  -- buffered read/write device.-  ---  -- There is no corresponding operation for read buffers, because before-  -- reading the client will always call 'fillReadBuffer'.-  emptyWriteBuffer  :: dev -> Buffer Word8 -> IO (Buffer Word8)-  emptyWriteBuffer _dev buf-    = return buf{ bufL=0, bufR=0, bufState = WriteBuffer }--  -- | Flush all the data from the supplied write buffer out to the device.-  -- The returned buffer should be empty, and ready for writing.-  flushWriteBuffer  :: dev -> Buffer Word8 -> IO (Buffer Word8)--  -- | Flush data from the supplied write buffer out to the device-  -- without blocking.  Returns the number of bytes written and the-  -- remaining buffer.-  flushWriteBuffer0 :: dev -> Buffer Word8 -> IO (Int, Buffer Word8)---- for an I/O device, these operations will perform reading/writing--- to/from the device.---- for a memory-mapped file, the buffer will be the whole file in--- memory.  fillReadBuffer sets the pointers to encompass the whole--- file, and flushWriteBuffer needs to do no I/O.  A memory-mapped--- file has to maintain its own file pointer.---- for a bytestring, again the buffer should match the bytestring in--- memory.---- ------------------------------------------------------------------------------ Low-level read/write to/from buffers---- These operations make it easy to implement an instance of 'BufferedIO'--- for an object that supports 'RawIO'.--readBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8)-readBuf dev bbuf = do-  let bytes = bufferAvailable bbuf-  let offset = bufferOffset bbuf-  res <- withBuffer bbuf $ \ptr ->-             RawIO.read dev (ptr `plusPtr` bufR bbuf) offset bytes-  let bbuf' = bufferAddOffset res bbuf-  return (res, bbuf'{ bufR = bufR bbuf' + res })-         -- zero indicates end of file--readBufNonBlocking :: RawIO dev => dev -> Buffer Word8-                     -> IO (Maybe Int,   -- Nothing ==> end of file-                                         -- Just n  ==> n bytes were read (n>=0)-                            Buffer Word8)-readBufNonBlocking dev bbuf = do-  let bytes = bufferAvailable bbuf-  let offset = bufferOffset bbuf-  res <- withBuffer bbuf $ \ptr ->-           IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) offset bytes-  case res of-     Nothing -> return (Nothing, bbuf)-     Just n  -> do let bbuf' = bufferAddOffset n bbuf-                   return (Just n, bbuf'{ bufR = bufR bbuf' + n })--writeBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Buffer Word8)-writeBuf dev bbuf = do-  let bytes = bufferElems bbuf-  let offset = bufferOffset bbuf-  withBuffer bbuf $ \ptr ->-      IODevice.write dev (ptr `plusPtr` bufL bbuf) offset bytes-  let bbuf' = bufferAddOffset bytes bbuf-  return bbuf'{ bufL=0, bufR=0 }---- XXX ToDo-writeBufNonBlocking :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8)-writeBufNonBlocking dev bbuf = do-  let bytes = bufferElems bbuf-  let offset = bufferOffset bbuf-  res <- withBuffer bbuf $ \ptr ->-            IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) offset bytes-  let bbuf' = bufferAddOffset bytes bbuf-  return (res, bufferAdjustL (bufL bbuf + res) bbuf')-
− GHC/IO/Device.hs 
@@ -1,180 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Device--- Copyright   :  (c) The University of Glasgow, 1994-2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Type classes for I/O providers.-----------------------------------------------------------------------------------module GHC.IO.Device (-        RawIO(..),-        IODevice(..),-        IODeviceType(..),-        SeekMode(..)-    ) where--import GHC.Base-import GHC.Word-import GHC.Arr-import GHC.Enum-import GHC.Read-import GHC.Show-import GHC.Ptr-import GHC.Num-import GHC.IO-import {-# SOURCE #-} GHC.IO.Exception ( unsupportedOperation )---- | A low-level I/O provider where the data is bytes in memory.---   The Word64 offsets currently have no effect on POSIX system or consoles---   where the implicit behaviour of the C runtime is assume to move the file---   pointer on every read/write without needing an explicit seek.-class RawIO a where-  -- | Read up to the specified number of bytes starting from a specified-  -- offset, returning the number of bytes actually read.  This function-  -- should only block if there is no data available.  If there is not enough-  -- data available, then the function should just return the available data.-  -- A return value of zero indicates that the end of the data stream (e.g. end-  -- of file) has been reached.-  read                :: a -> Ptr Word8 -> Word64 -> Int -> IO Int--  -- | Read up to the specified number of bytes starting from a specified-  -- offset, returning the number of bytes actually read, or 'Nothing' if-  -- the end of the stream has been reached.-  readNonBlocking     :: a -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int)--  -- | Write the specified number of bytes starting at a given offset.-  write               :: a -> Ptr Word8 -> Word64 -> Int -> IO ()--  -- | Write up to the specified number of bytes without blocking starting at a-  -- given offset.  Returns the actual number of bytes written.-  writeNonBlocking    :: a -> Ptr Word8 -> Word64 -> Int -> IO Int----- | I/O operations required for implementing a 'System.IO.Handle'.-class IODevice a where-  -- | @ready dev write msecs@ returns 'True' if the device has data-  -- to read (if @write@ is 'False') or space to write new data (if-  -- @write@ is 'True').  @msecs@ specifies how long to wait, in-  -- milliseconds.-  ---  ready :: a -> Bool -> Int -> IO Bool--  -- | closes the device.  Further operations on the device should-  -- produce exceptions.-  close :: a -> IO ()--  -- | returns 'True' if the device is a terminal or console.-  isTerminal :: a -> IO Bool-  isTerminal _ = return False--  -- | returns 'True' if the device supports 'seek' operations.-  isSeekable :: a -> IO Bool-  isSeekable _ = return False--  -- | seek to the specified position in the data.-  seek :: a -> SeekMode -> Integer -> IO Integer-  seek _ _ _ = ioe_unsupportedOperation--  -- | return the current position in the data.-  tell :: a -> IO Integer-  tell _ = ioe_unsupportedOperation--  -- | return the size of the data.-  getSize :: a -> IO Integer-  getSize _ = ioe_unsupportedOperation--  -- | change the size of the data.-  setSize :: a -> Integer -> IO ()-  setSize _ _ = ioe_unsupportedOperation--  -- | for terminal devices, changes whether characters are echoed on-  -- the device.-  setEcho :: a -> Bool -> IO ()-  setEcho _ _ = ioe_unsupportedOperation--  -- | returns the current echoing status.-  getEcho :: a -> IO Bool-  getEcho _ = ioe_unsupportedOperation--  -- | some devices (e.g. terminals) support a "raw" mode where-  -- characters entered are immediately made available to the program.-  -- If available, this operations enables raw mode.-  setRaw :: a -> Bool -> IO ()-  setRaw _ _ = ioe_unsupportedOperation--  -- | returns the 'IODeviceType' corresponding to this device.-  devType :: a -> IO IODeviceType--  -- | duplicates the device, if possible.  The new device is expected-  -- to share a file pointer with the original device (like Unix @dup@).-  dup :: a -> IO a-  dup _ = ioe_unsupportedOperation--  -- | @dup2 source target@ replaces the target device with the source-  -- device.  The target device is closed first, if necessary, and then-  -- it is made into a duplicate of the first device (like Unix @dup2@).-  dup2 :: a -> a -> IO a-  dup2 _ _ = ioe_unsupportedOperation--ioe_unsupportedOperation :: IO a-ioe_unsupportedOperation = throwIO unsupportedOperation---- | Type of a device that can be used to back a--- 'GHC.IO.Handle.Handle' (see also 'GHC.IO.Handle.mkFileHandle'). The--- standard libraries provide creation of 'GHC.IO.Handle.Handle's via--- Posix file operations with file descriptors (see--- 'GHC.IO.Handle.FD.mkHandleFromFD') with FD being the underlying--- 'GHC.IO.Device.IODevice' instance.------ Users may provide custom instances of 'GHC.IO.Device.IODevice'--- which are expected to conform the following rules:--data IODeviceType-  = Directory -- ^ The standard libraries do not have direct support-              -- for this device type, but a user implementation is-              -- expected to provide a list of file names in-              -- the directory, in any order, separated by @\'\\0\'@-              -- characters, excluding the @"."@ and @".."@ names. See-              -- also 'System.Directory.getDirectoryContents'.  Seek-              -- operations are not supported on directories (other-              -- than to the zero position).-  | Stream    -- ^ A duplex communications channel (results in-              -- creation of a duplex 'GHC.IO.Handle.Handle'). The-              -- standard libraries use this device type when-              -- creating 'GHC.IO.Handle.Handle's for open sockets.-  | RegularFile -- ^ A file that may be read or written, and also-                -- may be seekable.-  | RawDevice -- ^ A "raw" (disk) device which supports block binary-              -- read and write operations and may be seekable only-              -- to positions of certain granularity (block--              -- aligned).-  deriving ( Eq -- ^ @since 4.2.0.0-           )---- -------------------------------------------------------------------------------- SeekMode type---- | A mode that determines the effect of 'System.IO.hSeek' @hdl mode i@.-data SeekMode-  = AbsoluteSeek        -- ^ the position of @hdl@ is set to @i@.-  | RelativeSeek        -- ^ the position of @hdl@ is set to offset @i@-                        -- from the current position.-  | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@-                        -- from the end of the file.-    deriving ( Eq   -- ^ @since 4.2.0.0-             , Ord  -- ^ @since 4.2.0.0-             , Ix   -- ^ @since 4.2.0.0-             , Enum -- ^ @since 4.2.0.0-             , Read -- ^ @since 4.2.0.0-             , Show -- ^ @since 4.2.0.0-             )-
− GHC/IO/Encoding.hs 
@@ -1,342 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding--- Copyright   :  (c) The University of Glasgow, 2008-2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Text codecs for I/O-----------------------------------------------------------------------------------module GHC.IO.Encoding (-        BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder, CodingProgress(..),-        latin1, latin1_encode, latin1_decode,-        utf8, utf8_bom,-        utf16, utf16le, utf16be,-        utf32, utf32le, utf32be,-        initLocaleEncoding,-        getLocaleEncoding, getFileSystemEncoding, getForeignEncoding,-        setLocaleEncoding, setFileSystemEncoding, setForeignEncoding,-        char8,-        mkTextEncoding,-        argvEncoding-    ) where--import GHC.Base-import GHC.IO.Exception-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-#if !defined(mingw32_HOST_OS)-import qualified GHC.IO.Encoding.Iconv as Iconv-#else-import qualified GHC.IO.Encoding.CodePage as CodePage-import Text.Read (reads)-#endif-import qualified GHC.IO.Encoding.Latin1 as Latin1-import qualified GHC.IO.Encoding.UTF8   as UTF8-import qualified GHC.IO.Encoding.UTF16  as UTF16-import qualified GHC.IO.Encoding.UTF32  as UTF32-import GHC.List-import GHC.Word--import Data.IORef-import Data.Char (toUpper)-import System.IO.Unsafe (unsafePerformIO)---- --------------------------------------------------------------------------------- | The Latin1 (ISO8859-1) encoding.  This encoding maps bytes--- directly to the first 256 Unicode code points, and is thus not a--- complete Unicode encoding.  An attempt to write a character greater than--- @\'\\255\'@ to a 'System.IO.Handle' using the 'latin1' encoding will result in an--- error.-latin1  :: TextEncoding-latin1 = Latin1.latin1_checked---- | The UTF-8 Unicode encoding-utf8  :: TextEncoding-utf8 = UTF8.utf8---- | The UTF-8 Unicode encoding, with a byte-order-mark (BOM; the byte--- sequence 0xEF 0xBB 0xBF).  This encoding behaves like 'utf8',--- except that on input, the BOM sequence is ignored at the beginning--- of the stream, and on output, the BOM sequence is prepended.------ The byte-order-mark is strictly unnecessary in UTF-8, but is--- sometimes used to identify the encoding of a file.----utf8_bom  :: TextEncoding-utf8_bom = UTF8.utf8_bom---- | The UTF-16 Unicode encoding (a byte-order-mark should be used to--- indicate endianness).-utf16  :: TextEncoding-utf16 = UTF16.utf16---- | The UTF-16 Unicode encoding (little-endian)-utf16le  :: TextEncoding-utf16le = UTF16.utf16le---- | The UTF-16 Unicode encoding (big-endian)-utf16be  :: TextEncoding-utf16be = UTF16.utf16be---- | The UTF-32 Unicode encoding (a byte-order-mark should be used to--- indicate endianness).-utf32  :: TextEncoding-utf32 = UTF32.utf32---- | The UTF-32 Unicode encoding (little-endian)-utf32le  :: TextEncoding-utf32le = UTF32.utf32le---- | The UTF-32 Unicode encoding (big-endian)-utf32be  :: TextEncoding-utf32be = UTF32.utf32be---- | The Unicode encoding of the current locale------ @since 4.5.0.0-getLocaleEncoding :: IO TextEncoding-{-# NOINLINE getLocaleEncoding #-}---- | The Unicode encoding of the current locale, but allowing arbitrary--- undecodable bytes to be round-tripped through it.------ This 'TextEncoding' is used to decode and encode command line arguments--- and environment variables on non-Windows platforms.------ On Windows, this encoding *should not* be used if possible because--- the use of code pages is deprecated: Strings should be retrieved--- via the "wide" W-family of UTF-16 APIs instead------ @since 4.5.0.0-getFileSystemEncoding :: IO TextEncoding-{-# NOINLINE getFileSystemEncoding #-}---- | The Unicode encoding of the current locale, but where undecodable--- bytes are replaced with their closest visual match. Used for--- the 'Foreign.C.String.CString' marshalling functions in "Foreign.C.String"------ @since 4.5.0.0-getForeignEncoding :: IO TextEncoding-{-# NOINLINE getForeignEncoding #-}---- | Set locale encoding for your program. The locale affects--- how 'Char's are encoded and decoded when serialized to bytes: e. g.,--- when you read or write files ('System.IO.readFile'', 'System.IO.writeFile')--- or use standard input/output ('System.IO.getLine', 'System.IO.putStrLn').--- For instance, if your program prints non-ASCII characters, it is prudent to execute------ > setLocaleEncoding utf8------ This is necessary, but not enough on Windows, where console is--- a stateful device, which needs to be configured using--- @System.Win32.Console.setConsoleOutputCP@ and restored back afterwards.--- These intricacies are covered by--- <https://hackage.haskell.org/package/code-page code-page> package,--- which offers a crossplatform @System.IO.CodePage.withCodePage@ bracket.------ Wrong locale encoding typically causes error messages like--- "invalid argument (cannot decode byte sequence starting from ...)"--- or "invalid argument (cannot encode character ...)".------ @since 4.5.0.0-setLocaleEncoding :: TextEncoding -> IO ()-{-# NOINLINE setLocaleEncoding #-}---- | @since 4.5.0.0-setFileSystemEncoding :: TextEncoding -> IO ()-{-# NOINLINE setFileSystemEncoding #-}---- | @since 4.5.0.0-setForeignEncoding :: TextEncoding -> IO ()-{-# NOINLINE setForeignEncoding #-}--(getLocaleEncoding, setLocaleEncoding)         = mkGlobal initLocaleEncoding-(getFileSystemEncoding, setFileSystemEncoding) = mkGlobal initFileSystemEncoding-(getForeignEncoding, setForeignEncoding)       = mkGlobal initForeignEncoding--mkGlobal :: a -> (IO a, a -> IO ())-mkGlobal x = unsafePerformIO $ do-    x_ref <- newIORef x-    return (readIORef x_ref, writeIORef x_ref)-{-# NOINLINE mkGlobal #-}---- | @since 4.5.0.0-initLocaleEncoding, initFileSystemEncoding, initForeignEncoding :: TextEncoding-{-# NOINLINE initLocaleEncoding #-}--- N.B. initLocaleEncoding is exported for use in System.IO.localeEncoding.--- NOINLINE ensures that this result is shared.--#if !defined(mingw32_HOST_OS)--- It is rather important that we don't just call Iconv.mkIconvEncoding here--- because some iconvs (in particular GNU iconv) will brokenly UTF-8 encode--- lone surrogates without complaint.------ By going through our Haskell implementations of those encodings, we are--- guaranteed to catch such errors.------ FIXME: this is not a complete solution because if the locale encoding is one--- which we don't have a Haskell-side decoder for, iconv might still ignore the--- lone surrogate in the input.-initLocaleEncoding     = unsafePerformIO $ mkTextEncoding' ErrorOnCodingFailure Iconv.localeEncodingName-initFileSystemEncoding = unsafePerformIO $ mkTextEncoding' RoundtripFailure     Iconv.localeEncodingName-initForeignEncoding    = unsafePerformIO $ mkTextEncoding' IgnoreCodingFailure  Iconv.localeEncodingName-#else-initLocaleEncoding     = CodePage.localeEncoding-initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure-initForeignEncoding    = CodePage.mkLocaleEncoding IgnoreCodingFailure-#endif---- See Note [Windows Unicode Arguments] in rts/RtsFlags.c--- On Windows we assume hs_init argv is in utf8 encoding.---- | Internal encoding of argv-argvEncoding :: IO TextEncoding-#if defined(mingw32_HOST_OS)-argvEncoding = return utf8-#else-argvEncoding = getFileSystemEncoding-#endif---- | An encoding in which Unicode code points are translated to bytes--- by taking the code point modulo 256.  When decoding, bytes are--- translated directly into the equivalent code point.------ This encoding never fails in either direction.  However, encoding--- discards information, so encode followed by decode is not the--- identity.------ @since 4.4.0.0-char8 :: TextEncoding-char8 = Latin1.latin1---- | Look up the named Unicode encoding.  May fail with------  * 'System.IO.Error.isDoesNotExistError' if the encoding is unknown------ The set of known encodings is system-dependent, but includes at least:------  * @UTF-8@------  * @UTF-16@, @UTF-16BE@, @UTF-16LE@------  * @UTF-32@, @UTF-32BE@, @UTF-32LE@------ There is additional notation (borrowed from GNU iconv) for specifying--- how illegal characters are handled:------  * a suffix of @\/\/IGNORE@, e.g. @UTF-8\/\/IGNORE@, will cause---    all illegal sequences on input to be ignored, and on output---    will drop all code points that have no representation in the---    target encoding.------  * a suffix of @\/\/TRANSLIT@ will choose a replacement character---    for illegal sequences or code points.------  * a suffix of @\/\/ROUNDTRIP@ will use a PEP383-style escape mechanism---    to represent any invalid bytes in the input as Unicode codepoints (specifically,---    as lone surrogates, which are normally invalid in UTF-32).---    Upon output, these special codepoints are detected and turned back into the---    corresponding original byte.------    In theory, this mechanism allows arbitrary data to be roundtripped via---    a 'String' with no loss of data. In practice, there are two limitations---    to be aware of:------      1. This only stands a chance of working for an encoding which is an ASCII---         superset, as for security reasons we refuse to escape any bytes smaller---         than 128. Many encodings of interest are ASCII supersets (in particular,---         you can assume that the locale encoding is an ASCII superset) but many---         (such as UTF-16) are not.------      2. If the underlying encoding is not itself roundtrippable, this mechanism---         can fail. Roundtrippable encodings are those which have an injective mapping---         into Unicode. Almost all encodings meet this criteria, but some do not. Notably,---         Shift-JIS (CP932) and Big5 contain several different encodings of the same---         Unicode codepoint.------ On Windows, you can access supported code pages with the prefix--- @CP@; for example, @\"CP1250\"@.----mkTextEncoding :: String -> IO TextEncoding-mkTextEncoding e = case mb_coding_failure_mode of-    Nothing -> unknownEncodingErr e-    Just cfm -> mkTextEncoding' cfm enc-  where-    (enc, suffix) = span (/= '/') e-    mb_coding_failure_mode = case suffix of-        ""            -> Just ErrorOnCodingFailure-        "//IGNORE"    -> Just IgnoreCodingFailure-        "//TRANSLIT"  -> Just TransliterateCodingFailure-        "//ROUNDTRIP" -> Just RoundtripFailure-        _             -> Nothing--mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding-mkTextEncoding' cfm enc =-  case [toUpper c | c <- enc, c /= '-'] of-  -- UTF-8 and friends we can handle ourselves-    "UTF8"    -> return $ UTF8.mkUTF8 cfm-    "UTF16"   -> return $ UTF16.mkUTF16 cfm-    "UTF16LE" -> return $ UTF16.mkUTF16le cfm-    "UTF16BE" -> return $ UTF16.mkUTF16be cfm-    "UTF32"   -> return $ UTF32.mkUTF32 cfm-    "UTF32LE" -> return $ UTF32.mkUTF32le cfm-    "UTF32BE" -> return $ UTF32.mkUTF32be cfm-    -- On AIX, we want to avoid iconv, because it is either-    -- a) totally broken, or b) non-reentrant, or c) actually works.-    -- Detecting b) is difficult as you'd have to trigger the reentrancy-    -- corruption.-    -- Therefore, on AIX, we handle the popular ASCII and latin1 encodings-    -- ourselves. For consistency, we do the same on other platforms.-    -- We use `mkLatin1_checked` instead of `mkLatin1`, since the latter-    -- completely ignores the CodingFailureMode (TEST=encoding005).-    _ | isAscii -> return (Latin1.mkAscii cfm)-    _ | isLatin1 -> return (Latin1.mkLatin1_checked cfm)-#if defined(mingw32_HOST_OS)-    'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp-    _ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)-#else-    -- Otherwise, handle other encoding needs via iconv.--    -- Unfortunately there is no good way to determine whether iconv is actually-    -- functional without telling it to do something.-    _ -> do res <- Iconv.mkIconvEncoding cfm enc-            case res of-              Just e -> return e-              Nothing -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)-#endif-  where-    isAscii = enc `elem` asciiEncNames-    isLatin1 = enc `elem` latin1EncNames-    asciiEncNames = -- ASCII aliases specified by RFC 1345 and RFC 3808.-      [ "ANSI_X3.4-1968", "iso-ir-6", "ANSI_X3.4-1986", "ISO_646.irv:1991"-      , "US-ASCII", "us", "IBM367", "cp367", "csASCII", "ASCII", "ISO646-US"-      ]-    latin1EncNames = -- latin1 aliases specified by RFC 1345 and RFC 3808.-      [ "ISO_8859-1:1987", "iso-ir-100", "ISO_8859-1", "ISO-8859-1", "latin1",-        "l1", "IBM819", "CP819", "csISOLatin1"-      ]---latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)-latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8---latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode--latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)-latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output---latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode--unknownEncodingErr :: String -> IO a-unknownEncodingErr e = ioException (IOError Nothing NoSuchThing "mkTextEncoding"-                                            ("unknown encoding:" ++ e)  Nothing Nothing)
− GHC/IO/Encoding.hs-boot 
@@ -1,10 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO.Encoding where--import GHC.IO (IO)-import GHC.IO.Encoding.Types--getLocaleEncoding, getFileSystemEncoding, getForeignEncoding :: IO TextEncoding-
− GHC/IO/Encoding/CodePage.hs 
@@ -1,184 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE Trustworthy #-}--module GHC.IO.Encoding.CodePage(-#if defined(mingw32_HOST_OS)-                        codePageEncoding, mkCodePageEncoding,-                        localeEncoding, mkLocaleEncoding, CodePage,-                        getCurrentCodePage-#endif-                            ) where--#if !defined(mingw32_HOST_OS)-import GHC.Base () -- Build ordering-#else-import GHC.Base-import GHC.Show-import GHC.Num-import GHC.Enum-import GHC.Word-import GHC.IO (unsafePerformIO)-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-import GHC.IO.Buffer-import Data.Bits-import Data.Maybe-import Data.OldList (lookup)--import qualified GHC.IO.Encoding.CodePage.API as API-import GHC.IO.Encoding.CodePage.Table--import GHC.IO.Encoding.UTF8 (mkUTF8)-import GHC.IO.Encoding.UTF16 (mkUTF16le, mkUTF16be)-import GHC.IO.Encoding.UTF32 (mkUTF32le, mkUTF32be)--import GHC.Windows (DWORD)--#include "windows_cconv.h"--type CodePage = DWORD---- note CodePage = UInt which might not work on Win64.  But the Win32 package--- also has this issue.-getCurrentCodePage :: IO CodePage-getCurrentCodePage = do-    conCP <- getConsoleCP-    if conCP > 0-        then return conCP-        else getACP---- Since the Win32 package depends on base, we have to import these ourselves:-foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP"-    getConsoleCP :: IO Word32--foreign import WINDOWS_CCONV unsafe "windows.h GetACP"-    getACP :: IO Word32--{-# NOINLINE currentCodePage #-}-currentCodePage :: Word32-currentCodePage = unsafePerformIO getCurrentCodePage--localeEncoding :: TextEncoding-localeEncoding = mkLocaleEncoding ErrorOnCodingFailure--mkLocaleEncoding :: CodingFailureMode -> TextEncoding-mkLocaleEncoding cfm = mkCodePageEncoding cfm currentCodePage---codePageEncoding :: Word32 -> TextEncoding-codePageEncoding = mkCodePageEncoding ErrorOnCodingFailure--mkCodePageEncoding :: CodingFailureMode -> Word32 -> TextEncoding-mkCodePageEncoding cfm 65001 = mkUTF8 cfm-mkCodePageEncoding cfm 1200 = mkUTF16le cfm-mkCodePageEncoding cfm 1201 = mkUTF16be cfm-mkCodePageEncoding cfm 12000 = mkUTF32le cfm-mkCodePageEncoding cfm 12001 = mkUTF32be cfm-mkCodePageEncoding cfm cp = maybe (API.mkCodePageEncoding cfm cp) (buildEncoding cfm cp) (lookup cp codePageMap)--buildEncoding :: CodingFailureMode -> Word32 -> CodePageArrays -> TextEncoding-buildEncoding cfm cp SingleByteCP {decoderArray = dec, encoderArray = enc}-  = TextEncoding {-      textEncodingName = "CP" ++ show cp-    , mkTextDecoder = return $ simpleCodec (recoverDecode cfm) $ decodeFromSingleByte dec-    , mkTextEncoder = return $ simpleCodec (recoverEncode cfm) $ encodeToSingleByte enc-    }--simpleCodec :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))-            -> (Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to))-                -> BufferCodec from to ()-simpleCodec r f = BufferCodec {-    encode = f,-    recover = r,-    close = return (),-    getState = return (),-    setState = return-  }--decodeFromSingleByte :: ConvArray Char -> DecodeBuffer-decodeFromSingleByte convArr-    input@Buffer  { bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-    output@Buffer { bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }-  = let-        done why !ir !ow = return (why,-                                   if ir==iw then input{ bufL=0, bufR=0}-                                             else input{ bufL=ir},-                                   output {bufR=ow})-        loop !ir !ow-            | ow >= os  = done OutputUnderflow ir ow-            | ir >= iw  = done InputUnderflow ir ow-            | otherwise = do-                b <- readWord8Buf iraw ir-                let c = lookupConv convArr b-                if c=='\0' && b /= 0 then invalid else do-                ow' <- writeCharBuf oraw ow c-                loop (ir+1) ow'-          where-            invalid = done InvalidSequence ir ow-    in loop ir0 ow0--encodeToSingleByte :: CompactArray Char Word8 -> EncodeBuffer-encodeToSingleByte CompactArray { encoderMax = maxChar,-                         encoderIndices = indices,-                         encoderValues = values }-    input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ }-    output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }-  = let-        done why !ir !ow = return (why,-                                   if ir==iw then input { bufL=0, bufR=0 }-                                             else input { bufL=ir },-                                   output {bufR=ow})-        loop !ir !ow-            | ow >= os  = done OutputUnderflow ir ow-            | ir >= iw  = done InputUnderflow ir ow-            | otherwise = do-                (c,ir') <- readCharBuf iraw ir-                case lookupCompact maxChar indices values c of-                    Nothing -> invalid-                    Just 0 | c /= '\0' -> invalid-                    Just b -> do-                        writeWord8Buf oraw ow b-                        loop ir' (ow+1)-            where-                invalid = done InvalidSequence ir ow-    in-    loop ir0 ow0-------------------------------------------------- Array access functions---- {-# INLINE lookupConv #-}-lookupConv :: ConvArray Char -> Word8 -> Char-lookupConv a = indexChar a . fromEnum--{-# INLINE lookupCompact #-}-lookupCompact :: Char -> ConvArray Int -> ConvArray Word8 -> Char -> Maybe Word8-lookupCompact maxVal indexes values x-    | x > maxVal = Nothing-    | otherwise = Just $ indexWord8 values $ j + (i .&. mask)-  where-    i = fromEnum x-    mask = (1 `shiftL` n) - 1-    k = i `shiftR` n-    j = indexInt indexes k-    n = blockBitSize--{-# INLINE indexInt #-}-indexInt :: ConvArray Int -> Int -> Int-indexInt (ConvArray p) (I# i) = I# (int16ToInt# (indexInt16OffAddr# p i))--{-# INLINE indexWord8 #-}-indexWord8 :: ConvArray Word8 -> Int -> Word8-indexWord8 (ConvArray p) (I# i) = W8# (indexWord8OffAddr# p i)--{-# INLINE indexChar #-}-indexChar :: ConvArray Char -> Int -> Char-indexChar (ConvArray p) (I# i) = C# (chr# (int16ToInt# (indexInt16OffAddr# p i)))--#endif-
− GHC/IO/Encoding/CodePage/API.hs 
@@ -1,424 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, NondecreasingIndentation,-             RecordWildCards, ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module GHC.IO.Encoding.CodePage.API (-    mkCodePageEncoding-  ) where---- Required for WORDS_BIGENDIAN-#include <ghcautoconf.h>--import Foreign.C-import Foreign.Ptr-import Foreign.Marshal-import Foreign.Storable-import Data.Bits-import Data.Either-import Data.Word--import GHC.Base-import GHC.List-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-import GHC.IO.Encoding.UTF16-import GHC.Num-import GHC.Show-import GHC.Real-import GHC.Windows hiding (LPCSTR)-import GHC.ForeignPtr (castForeignPtr)--import System.Posix.Internals---c_DEBUG_DUMP :: Bool-c_DEBUG_DUMP = False--debugIO :: String -> IO ()-debugIO s- | c_DEBUG_DUMP = puts s- | otherwise    = return ()--#include "windows_cconv.h"--type LPCSTR = Ptr Word8---mAX_DEFAULTCHAR :: Int-mAX_DEFAULTCHAR = 2--mAX_LEADBYTES :: Int-mAX_LEADBYTES = 12---- Don't really care about the contents of this, but we have to make sure the size is right-data CPINFO = CPINFO {-    maxCharSize :: UINT,-    defaultChar :: [BYTE], -- ^ Always of length mAX_DEFAULTCHAR-    leadByte    :: [BYTE]  -- ^ Always of length mAX_LEADBYTES-  }---- | @since 4.7.0.0-instance Storable CPINFO where-    sizeOf    _ = sizeOf (undefined :: UINT) + (mAX_DEFAULTCHAR + mAX_LEADBYTES) * sizeOf (undefined :: BYTE)-    alignment _ = alignment (undefined :: CInt)-    peek ptr = do-      ptr <- return $ castPtr ptr-      a <- peek ptr-      ptr <- return $ castPtr $ advancePtr ptr 1-      b <- peekArray mAX_DEFAULTCHAR ptr-      c <- peekArray mAX_LEADBYTES   (advancePtr ptr mAX_DEFAULTCHAR)-      return $ CPINFO a b c-    poke ptr val = do-      ptr <- return $ castPtr ptr-      poke ptr (maxCharSize val)-      ptr <- return $ castPtr $ advancePtr ptr 1-      pokeArray' "CPINFO.defaultChar" mAX_DEFAULTCHAR ptr                              (defaultChar val)-      pokeArray' "CPINFO.leadByte"    mAX_LEADBYTES   (advancePtr ptr mAX_DEFAULTCHAR) (leadByte val)--pokeArray' :: Storable a => String -> Int -> Ptr a -> [a] -> IO ()-pokeArray' msg sz ptr xs | length xs == sz = pokeArray ptr xs-                         | otherwise       = errorWithoutStackTrace $ msg ++ ": expected " ++ show sz ++ " elements in list but got " ++ show (length xs)---foreign import WINDOWS_CCONV unsafe "windows.h GetCPInfo"-    c_GetCPInfo :: UINT       -- ^ CodePage-                -> Ptr CPINFO -- ^ lpCPInfo-                -> IO BOOL--foreign import WINDOWS_CCONV unsafe "windows.h MultiByteToWideChar"-    c_MultiByteToWideChar :: UINT   -- ^ CodePage-                          -> DWORD  -- ^ dwFlags-                          -> LPCSTR -- ^ lpMultiByteStr-                          -> CInt   -- ^ cbMultiByte-                          -> LPWSTR -- ^ lpWideCharStr-                          -> CInt   -- ^ cchWideChar-                          -> IO CInt--foreign import WINDOWS_CCONV unsafe "windows.h WideCharToMultiByte"-    c_WideCharToMultiByte :: UINT   -- ^ CodePage-                          -> DWORD  -- ^ dwFlags-                          -> LPWSTR -- ^ lpWideCharStr-                          -> CInt   -- ^ cchWideChar-                          -> LPCSTR -- ^ lpMultiByteStr-                          -> CInt   -- ^ cbMultiByte-                          -> LPCSTR -- ^ lpDefaultChar-                          -> LPBOOL -- ^ lpUsedDefaultChar-                          -> IO CInt--foreign import WINDOWS_CCONV unsafe "windows.h IsDBCSLeadByteEx"-    c_IsDBCSLeadByteEx :: UINT    -- ^ CodePage-                       -> BYTE    -- ^ TestChar-                       -> IO BOOL----- | Returns a slow but correct implementation of TextEncoding using the Win32 API.------ This is useful for supporting DBCS text encoding on the console without having to statically link--- in huge code tables into all of our executables, or just as a fallback mechanism if a new code page--- is introduced that we don't know how to deal with ourselves yet.-mkCodePageEncoding :: CodingFailureMode -> Word32 -> TextEncoding-mkCodePageEncoding cfm cp-  = TextEncoding {-        textEncodingName = "CP" ++ show cp,-        mkTextDecoder = newCP (recoverDecode cfm) cpDecode cp,-        mkTextEncoder = newCP (recoverEncode cfm) cpEncode cp-      }--newCP :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))-      -> (Word32 -> Int -> CodeBuffer from to)-      -> Word32-      -> IO (BufferCodec from to ())-newCP rec fn cp = do-  -- Fail early if the code page doesn't exist, to match the behaviour of the IConv TextEncoding-  max_char_size <- alloca $ \cpinfo_ptr -> do-    success <- c_GetCPInfo cp cpinfo_ptr-    when (not success) $ throwGetLastError ("GetCPInfo " ++ show cp)-    fmap (fromIntegral . maxCharSize) $ peek cpinfo_ptr--  debugIO $ "GetCPInfo " ++ show cp ++ " = " ++ show max_char_size--  return $ BufferCodec {-    encode = fn cp max_char_size,-    recover = rec,-    close  = return (),-    -- Windows doesn't supply a way to save/restore the state and doesn't need one-    -- since it's a dumb string->string API rather than a clever streaming one.-    getState = return (),-    setState = const $ return ()-  }---utf16_native_encode' :: EncodeBuffer-utf16_native_decode' :: DecodeBuffer-#if defined(WORDS_BIGENDIAN)-utf16_native_encode' = utf16be_encode-utf16_native_decode' = utf16be_decode-#else-utf16_native_encode' = utf16le_encode-utf16_native_decode' = utf16le_decode-#endif--saner :: CodeBuffer from to-      -> Buffer from -> Buffer to-      -> IO (CodingProgress, Int, Buffer from, Buffer to)-saner code ibuf obuf = do-  (why, ibuf', obuf') <- code ibuf obuf-  -- Weird but true: the UTF16 codes have a special case (see the "done" functions)-  -- whereby if they entirely consume the input instead of returning an input buffer-  -- that is empty because bufL has reached bufR, they return a buffer that is empty-  -- because bufL = bufR = 0.-  ---  -- This is really very odd and confusing for our code that expects the difference-  -- between the old and new input buffer bufLs to indicate the number of elements-  -- that were consumed!-  ---  -- We fix it by explicitly extracting an integer which is the # of things consumed, like so:-  if isEmptyBuffer ibuf'-   then return (InputUnderflow, bufferElems ibuf,       ibuf', obuf')-   else return (why,            bufL ibuf' - bufL ibuf, ibuf', obuf')--byteView :: Buffer CWchar -> Buffer Word8-byteView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = bufSize * 2, bufOffset = bufOffset, bufL = bufL * 2, bufR = bufR * 2 }--cwcharView :: Buffer Word8 -> Buffer CWchar-cwcharView (Buffer {..}) = Buffer { bufState = bufState, bufRaw = castForeignPtr bufRaw, bufSize = half bufSize, bufOffset = bufOffset, bufL = half bufL, bufR = half bufR }-  where half x = case x `divMod` 2 of (y, 0) -> y-                                      _      -> 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-  (why, ibuf, obuf) <- utf16_native_encode' ibuf (byteView obuf)-  return (why, ibuf, cwcharView obuf)--utf16_native_decode :: CodeBuffer CWchar Char-utf16_native_decode ibuf obuf = do-  (why, ibuf, obuf) <- utf16_native_decode' (byteView ibuf) obuf-  return (why, cwcharView ibuf, obuf)--cpDecode :: Word32 -> Int -> DecodeBuffer-cpDecode cp max_char_size = \ibuf obuf -> do-#if defined(CHARBUF_UTF16)-    let mbuf = obuf-#else-    -- FIXME: share the buffer between runs, even if the buffer is not the perfect size-    let sz =       (bufferElems ibuf * 2)     -- I guess in the worst case the input CP text consists of 1-byte sequences that map entirely to things outside the BMP and so require 2 UTF-16 chars-             `min` (bufferAvailable obuf * 2) -- In the best case, each pair of UTF-16 points becomes a single UTF-32 point-    mbuf <- newBuffer (2 * sz) sz WriteBuffer :: IO (Buffer CWchar)-#endif-    debugIO $ "cpDecode " ++ summaryBuffer ibuf ++ " " ++ summaryBuffer mbuf-    (why1, ibuf', mbuf') <- cpRecode try' is_valid_prefix max_char_size 1 0 1 ibuf mbuf-    debugIO $ "cpRecode (cpDecode) = " ++ show why1 ++ " " ++ summaryBuffer ibuf' ++ " " ++ summaryBuffer mbuf'-#if defined(CHARBUF_UTF16)-    return (why1, ibuf', mbuf')-#else-    -- Convert as much UTF-16 as possible to UTF-32. Note that it's impossible for this to fail-    -- due to illegal characters since the output from Window's encoding function should be correct UTF-16.-    -- However, it's perfectly possible to run out of either output or input buffer.-    debugIO $ "utf16_native_decode " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf-    (why2, target_utf16_count, mbuf', obuf) <- saner utf16_native_decode (mbuf' { bufState = ReadBuffer }) obuf-    debugIO $ "utf16_native_decode = " ++ show why2 ++ " " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf-    case why2 of-      -- 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           -> errorWithoutStackTrace "cpDecode: impossible underflown UTF-16 buffer"-      -- InvalidSequence should be impossible since mbuf' is output from Windows.-      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-        -- We have an interesting problem here similar to the cpEncode case where we have to figure out how much-        -- of the byte buffer was consumed to reach as far as the last UTF-16 character we actually decoded to UTF-32 OK.-        ---        -- The minimum number of bytes it could take is half the number of UTF-16 chars we got on the output, since-        -- one byte could theoretically generate two UTF-16 characters.-        -- The common case (ASCII text) is that every byte in the input maps to a single UTF-16 character.-        -- In the worst case max_char_size bytes map to each UTF-16 character.-        byte_count <- bSearch "cpDecode" (cpRecode try' is_valid_prefix max_char_size 1 0 1) ibuf mbuf target_utf16_count (target_utf16_count `div` 2) target_utf16_count (target_utf16_count * max_char_size)-        return (OutputUnderflow, bufferRemove byte_count ibuf, obuf)-#endif-  where-    is_valid_prefix = c_IsDBCSLeadByteEx cp-    try' iptr icnt optr ocnt-     -- MultiByteToWideChar does surprising things if you have ocnt == 0-     | ocnt == 0 = return (Left True)-     | otherwise = do-        err <- c_MultiByteToWideChar (fromIntegral cp) 8 -- MB_ERR_INVALID_CHARS == 8: Fail if an invalid input character is encountered-                                     iptr (fromIntegral icnt) optr (fromIntegral ocnt)-        debugIO $ "MultiByteToWideChar " ++ show cp ++ " 8 " ++ show iptr ++ " " ++ show icnt ++ " " ++ show optr ++ " " ++ show ocnt ++ "\n = " ++ show err-        case err of-          -- 0 indicates that we did not succeed-          0 -> do-            err <- getLastError-            case err of-                122  -> return (Left True)-                1113 -> return (Left False)-                _    -> failWith "MultiByteToWideChar" err-          wrote_chars -> return (Right (fromIntegral wrote_chars))--cpEncode :: Word32 -> Int -> EncodeBuffer-cpEncode cp _max_char_size = \ibuf obuf -> do-#if defined(CHARBUF_UTF16)-    let mbuf' = ibuf-#else-    -- FIXME: share the buffer between runs, even though that means we can't size the buffer as we want.-    let sz =       (bufferElems ibuf * 2)     -- UTF-32 always uses 4 bytes. UTF-16 uses at most 4 bytes.-             `min` (bufferAvailable obuf * 2) -- In the best case, each pair of UTF-16 points fits into only 1 byte-    mbuf <- newBuffer (2 * sz) sz WriteBuffer--    -- Convert as much UTF-32 as possible to UTF-16. NB: this can't fail due to output underflow-    -- since we sized the output buffer correctly. However, it could fail due to an illegal character-    -- in the input if it encounters a lone surrogate. In this case, our recovery will be applied as normal.-    (why1, ibuf', mbuf') <- utf16_native_encode ibuf mbuf-#endif-    debugIO $ "\ncpEncode " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf-    (why2, target_utf16_count, mbuf', obuf) <- saner (cpRecode try' is_valid_prefix 2 1 1 0) (mbuf' { bufState = ReadBuffer }) obuf-    debugIO $ "cpRecode (cpEncode) = " ++ show why2 ++ " " ++ summaryBuffer mbuf' ++ " " ++ summaryBuffer obuf-#if defined(CHARBUF_UTF16)-    return (why2, mbuf', obuf)-#else-    case why2 of-      -- If we successfully 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           -> 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.-      _ -> do-        -- Here is an interesting problem. If we have only managed to translate part of the mbuf'-        -- then we need to return an ibuf which has consumed exactly those bytes required to obtain-        -- that part of the mbuf'. To reconstruct this information, we binary search for the number of-        -- UTF-32 characters required to get the consumed count of UTF-16 characters:-        ---        -- When dealing with data from the BMP (the common case), consuming N UTF-16 characters will be the same as consuming N-        -- UTF-32 characters. We start our search there so that most binary searches will terminate in a single iteration.-        -- Furthermore, the absolute minimum number of UTF-32 characters this can correspond to is 1/2 the UTF-16 byte count-        -- (this will be realised when the input data is entirely not in the BMP).-        utf32_count <- bSearch "cpEncode" utf16_native_encode ibuf mbuf target_utf16_count (target_utf16_count `div` 2) target_utf16_count target_utf16_count-        return (why2, bufferRemove utf32_count ibuf, obuf)-#endif-  where-    -- Single characters should be mappable to bytes. If they aren't supported by the CP then we have an invalid input sequence.-    is_valid_prefix _ = return False--    try' iptr icnt optr ocnt-     -- WideCharToMultiByte does surprising things if you call it with ocnt == 0-     | ocnt == 0 = return (Left True)-     | otherwise = alloca $ \defaulted_ptr -> do-      poke defaulted_ptr False-      err <- c_WideCharToMultiByte (fromIntegral cp) 0 -- NB: the WC_ERR_INVALID_CHARS flag is useless: only has an effect with the UTF-8 code page-                                   iptr (fromIntegral icnt) optr (fromIntegral ocnt)-                                   nullPtr defaulted_ptr-      defaulted <- peek defaulted_ptr-      debugIO $ "WideCharToMultiByte " ++ show cp ++ " 0 " ++ show iptr ++ " " ++ show icnt ++ " " ++ show optr ++ " " ++ show ocnt ++ " NULL " ++ show defaulted_ptr ++ "\n = " ++ show err ++ ", " ++ show defaulted-      case err of-          -- 0 indicates that we did not succeed-          0 -> do-            err <- getLastError-            case err of-                122  -> return (Left True)-                1113 -> return (Left False)-                _    -> failWith "WideCharToMultiByte" err-          wrote_bytes | defaulted -> return (Left False)-                      | otherwise -> return (Right (fromIntegral wrote_bytes))--bSearch :: String-        -> CodeBuffer from to-        -> Buffer from -> Buffer to -- From buffer (crucial data source) and to buffer (temporary storage only). To buffer must be empty (L=R).-        -> Int               -- Target size of to buffer-        -> Int -> Int -> Int -- Binary search min, mid, max-        -> IO Int            -- Size of from buffer required to reach target size of to buffer-bSearch msg code ibuf mbuf target_to_elems = go-  where-    go mn md mx = do-      -- NB: this loop repeatedly reencodes on top of mbuf using a varying fraction of ibuf. It doesn't-      -- matter if we blast the contents of mbuf since we already consumed all of the contents we are going to use.-      (_why, ibuf, mbuf) <- code (ibuf { bufR = bufL ibuf + md }) mbuf-      debugIO $ "code (bSearch " ++ msg ++ ") " ++ show md ++ " = " ++ show _why ++ ", " ++ summaryBuffer ibuf ++ summaryBuffer mbuf-      -- The normal case is to get InputUnderflow here, which indicates that coding basically-      -- terminated normally.-      ---      -- However, InvalidSequence is also possible if we are being called from cpDecode if we-      -- have just been unlucky enough to set md so that ibuf straddles a byte boundary.-      -- In this case we have to be really careful, because we don't want to report that-      -- "md" elements is the right number when in actual fact we could have had md-1 input-      -- elements and still produced the same number of bufferElems in mbuf.-      ---      -- In fact, we have to worry about this possibility even if we get InputUnderflow-      -- since that will report InputUnderflow rather than InvalidSequence if the buffer-      -- ends in a valid lead byte. So the expedient thing to do is simply to check if-      -- the input buffer was entirely consumed.-      ---      -- When called from cpDecode, OutputUnderflow is also possible.-      ---      -- Luckily if we have InvalidSequence/OutputUnderflow and we do not appear to have reached-      -- the target, what we should do is the same as normal because the fraction of ibuf that our-      -- first "code" coded successfully must be invalid-sequence-free, and ibuf will always-      -- have been decoded as far as the first invalid sequence in it.-      case bufferElems mbuf `compare` target_to_elems of-        -- Coding n "from" chars from the input yields exactly as many "to" chars-        -- as were consumed by the recode. All is peachy:-        EQ -> debugIO ("bSearch = " ++ show solution) >> return solution-          where solution = md - bufferElems ibuf-        -- If we encoded fewer "to" characters than the target number, try again with more "from" characters (and vice-versa)-        LT -> go' (md+1) mx-        GT -> go' mn (md-1)-    go' mn mx | mn <= mx  = go mn (mn + ((mx - mn) `div` 2)) mx-              | otherwise = errorWithoutStackTrace $ "bSearch(" ++ msg ++ "): search crossed! " ++ show (summaryBuffer ibuf, summaryBuffer mbuf, target_to_elems, mn, mx)--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.-         -> Int -- ^ Minimum number of output elements per complete translatable sequence in the input (almost certainly 1)-         -> Int -> Int-         -> CodeBuffer from to-cpRecode try' is_valid_prefix max_i_size min_o_size iscale oscale = go-  where-    go :: CodeBuffer from to-    go ibuf obuf | isEmptyBuffer ibuf                = return (InputUnderflow,  ibuf, obuf)-                 | bufferAvailable obuf < min_o_size = return (OutputUnderflow, ibuf, obuf)-                 | otherwise                         = try (bufferElems ibuf `min` ((max_i_size * bufferAvailable obuf) `div` min_o_size)) seek_smaller-      where-        done why = return (why, ibuf, obuf)--        seek_smaller n longer_was_valid-          -- In this case, we can't shrink any further via any method. Calling (try 0) wouldn't be right because that will always claim InputUnderflow...-          | n <= 1 = if longer_was_valid-                      -- try m (where m >= n) was valid but we overflowed the output buffer with even a single input element-                      then done OutputUnderflow-                      -- there was no initial valid sequence in the input, but it might just be a truncated buffer - we need to check-                      else do byte <- withBuffer ibuf $ \ptr -> peekElemOff ptr (bufL ibuf)-                              valid_prefix <- is_valid_prefix byte-                              done (if valid_prefix && bufferElems ibuf < max_i_size then InputUnderflow else InvalidSequence)-          -- If we're already looking at very small buffers, try every n down to 1, to ensure we spot as long a sequence as exists while avoiding trying 0.-          -- Doing it this way ensures that we spot a single initial sequence of length <= max_i_size if any such exists.-          | n < 2 * max_i_size = try (n - 1) (\pred_n pred_n_was_valid -> seek_smaller pred_n (longer_was_valid || pred_n_was_valid))-          -- Otherwise, try a binary chop to try to either get the prefix before the invalid input, or shrink the output down so it fits-          -- in the output buffer. After the chop, try to consume extra input elements to try to recover as much of the sequence as possible if we-          -- end up chopping a multi-element input sequence into two parts.-          ---          -- Note that since max_i_size >= 1:-          --  * (n `div` 2) >= 1, so we don't try 0-          --  * ((n `div` 2) + (max_i_size - 1)) < n, so we don't get into a loop where (seek_smaller n) calls post_divide (n `div` 2) calls (seek_smaller n)-          | let n' = n `div` 2 = try n' (post_divide n' longer_was_valid)--        post_divide _  _                n True  = seek_smaller n True-        post_divide n' longer_was_valid n False | n < n' + max_i_size - 1 = try (n + 1) (post_divide n' longer_was_valid) -- There's still a chance..-                                                | otherwise               = seek_smaller n' longer_was_valid              -- No amount of recovery could save us :(--        try n k_fail = withBuffer ibuf $ \iptr -> withBuffer obuf $ \optr -> do-          ei_err_wrote <- try' (iptr `plusPtr` (bufL ibuf `shiftL` iscale)) n-                               (optr `plusPtr` (bufR obuf `shiftL` oscale)) (bufferAvailable obuf)-          debugIO $ "try " ++ show n ++ " = " ++ show ei_err_wrote-          case ei_err_wrote of-            -- ERROR_INSUFFICIENT_BUFFER: A supplied buffer size was not large enough, or it was incorrectly set to NULL.-            Left True  -> k_fail n True-            -- ERROR_NO_UNICODE_TRANSLATION: Invalid Unicode was found in a string.-            Left False -> k_fail n False-            -- Must have interpreted all given bytes successfully-            -- We need to iterate until we have consumed the complete contents of the buffer-            Right wrote_elts -> go (bufferRemove n ibuf) (obuf { bufR = bufR obuf + wrote_elts })
− GHC/IO/Encoding/CodePage/Table.hs 
@@ -1,432 +0,0 @@-{-# LANGUAGE MagicHash, NoImplicitPrelude #-}--- Do not edit this file directly!--- It was generated by the MakeTable.hs script using the files below.--- To regenerate it, run "make" in ../../../../codepages/--- --- Files:--- CP037.TXT--- CP1026.TXT--- CP1250.TXT--- CP1251.TXT--- CP1252.TXT--- CP1253.TXT--- CP1254.TXT--- CP1255.TXT--- CP1256.TXT--- CP1257.TXT--- CP1258.TXT--- CP437.TXT--- CP500.TXT--- CP737.TXT--- CP775.TXT--- CP850.TXT--- CP852.TXT--- CP855.TXT--- CP857.TXT--- CP860.TXT--- CP861.TXT--- CP862.TXT--- CP863.TXT--- CP864.TXT--- CP865.TXT--- CP866.TXT--- CP869.TXT--- CP874.TXT--- CP875.TXT-module GHC.IO.Encoding.CodePage.Table where--import GHC.Prim-import GHC.Base-import GHC.Word-data ConvArray a = ConvArray Addr#-data CompactArray a b = CompactArray {-    encoderMax :: !a,-    encoderIndices :: !(ConvArray Int),-    encoderValues :: !(ConvArray b)-  }--data CodePageArrays = SingleByteCP {-    decoderArray :: !(ConvArray Char),-    encoderArray :: !(CompactArray Char Word8)-  }--blockBitSize :: Int-blockBitSize = 6-codePageMap :: [(Word32, CodePageArrays)]-codePageMap = [-    (37, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\xa0\x0\xe2\x0\xe4\x0\xe0\x0\xe1\x0\xe3\x0\xe5\x0\xe7\x0\xf1\x0\xa2\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x7c\x0\x26\x0\xe9\x0\xea\x0\xeb\x0\xe8\x0\xed\x0\xee\x0\xef\x0\xec\x0\xdf\x0\x21\x0\x24\x0\x2a\x0\x29\x0\x3b\x0\xac\x0\x2d\x0\x2f\x0\xc2\x0\xc4\x0\xc0\x0\xc1\x0\xc3\x0\xc5\x0\xc7\x0\xd1\x0\xa6\x0\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xf8\x0\xc9\x0\xca\x0\xcb\x0\xc8\x0\xcd\x0\xce\x0\xcf\x0\xcc\x0\x60\x0\x3a\x0\x23\x0\x40\x0\x27\x0\x3d\x0\x22\x0\xd8\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xab\x0\xbb\x0\xf0\x0\xfd\x0\xfe\x0\xb1\x0\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xaa\x0\xba\x0\xe6\x0\xb8\x0\xc6\x0\xa4\x0\xb5\x0\x7e\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xa1\x0\xbf\x0\xd0\x0\xdd\x0\xde\x0\xae\x0\x5e\x0\xa3\x0\xa5\x0\xb7\x0\xa9\x0\xa7\x0\xb6\x0\xbc\x0\xbd\x0\xbe\x0\x5b\x0\x5d\x0\xaf\x0\xa8\x0\xb4\x0\xd7\x0\x7b\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xf4\x0\xf6\x0\xf2\x0\xf3\x0\xf5\x0\x7d\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb9\x0\xfb\x0\xfc\x0\xf9\x0\xfa\x0\xff\x0\x5c\x0\xf7\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xd4\x0\xd6\x0\xd2\x0\xd3\x0\xd5\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xdb\x0\xdc\x0\xd9\x0\xda\x0\x9f\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f\x40\x5a\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xba\xe0\xbb\xb0\x6d\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\x4f\xd0\xa1\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x41\xaa\x4a\xb1\x9f\xb2\x6a\xb5\xbd\xb4\x9a\x8a\x5f\xca\xaf\xbc\x90\x8f\xea\xfa\xbe\xa0\xb6\xb3\x9d\xda\x9b\x8b\xb7\xb8\xb9\xab\x64\x65\x62\x66\x63\x67\x9e\x68\x74\x71\x72\x73\x78\x75\x76\x77\xac\x69\xed\xee\xeb\xef\xec\xbf\x80\xfd\xfe\xfb\xfc\xad\xae\x59\x44\x45\x42\x46\x43\x47\x9c\x48\x54\x51\x52\x53\x58\x55\x56\x57\x8c\x49\xcd\xce\xcb\xcf\xcc\xe1\x70\xdd\xde\xdb\xdc\x8d\x8e\xdf"#-        , encoderMax = '\255'-        }--   }-    )--    ,-    (1026, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\xa0\x0\xe2\x0\xe4\x0\xe0\x0\xe1\x0\xe3\x0\xe5\x0\x7b\x0\xf1\x0\xc7\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x21\x0\x26\x0\xe9\x0\xea\x0\xeb\x0\xe8\x0\xed\x0\xee\x0\xef\x0\xec\x0\xdf\x0\x1e\x1\x30\x1\x2a\x0\x29\x0\x3b\x0\x5e\x0\x2d\x0\x2f\x0\xc2\x0\xc4\x0\xc0\x0\xc1\x0\xc3\x0\xc5\x0\x5b\x0\xd1\x0\x5f\x1\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xf8\x0\xc9\x0\xca\x0\xcb\x0\xc8\x0\xcd\x0\xce\x0\xcf\x0\xcc\x0\x31\x1\x3a\x0\xd6\x0\x5e\x1\x27\x0\x3d\x0\xdc\x0\xd8\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xab\x0\xbb\x0\x7d\x0\x60\x0\xa6\x0\xb1\x0\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xaa\x0\xba\x0\xe6\x0\xb8\x0\xc6\x0\xa4\x0\xb5\x0\xf6\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xa1\x0\xbf\x0\x5d\x0\x24\x0\x40\x0\xae\x0\xa2\x0\xa3\x0\xa5\x0\xb7\x0\xa9\x0\xa7\x0\xb6\x0\xbc\x0\xbd\x0\xbe\x0\xac\x0\x7c\x0\xaf\x0\xa8\x0\xb4\x0\xd7\x0\xe7\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xf4\x0\x7e\x0\xf2\x0\xf3\x0\xf5\x0\x1f\x1\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb9\x0\xfb\x0\x5c\x0\xf9\x0\xfa\x0\xff\x0\xfc\x0\xf7\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xd4\x0\x23\x0\xd2\x0\xd3\x0\xd5\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xdb\x0\x22\x0\xd9\x0\xda\x0\x9f\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f\x40\x4f\xfc\xec\xad\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\xae\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\x68\xdc\xac\x5f\x6d\x8d\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\x48\xbb\x8c\xcc\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x41\xaa\xb0\xb1\x9f\xb2\x8e\xb5\xbd\xb4\x9a\x8a\xba\xca\xaf\xbc\x90\x8f\xea\xfa\xbe\xa0\xb6\xb3\x9d\xda\x9b\x8b\xb7\xb8\xb9\xab\x64\x65\x62\x66\x63\x67\x9e\x4a\x74\x71\x72\x73\x78\x75\x76\x77\x0\x69\xed\xee\xeb\xef\x7b\xbf\x80\xfd\xfe\xfb\x7f\x0\x0\x59\x44\x45\x42\x46\x43\x47\x9c\xc0\x54\x51\x52\x53\x58\x55\x56\x57\x0\x49\xcd\xce\xcb\xcf\xa1\xe1\x70\xdd\xde\xdb\xe0\x0\x0\xdf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x5a\xd0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x5b\x79\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x7c\x6a"#-        , encoderMax = '\351'-        }--   }-    )--    ,-    (1250, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x0\x0\x1e\x20\x26\x20\x20\x20\x21\x20\x0\x0\x30\x20\x60\x1\x39\x20\x5a\x1\x64\x1\x7d\x1\x79\x1\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x61\x1\x3a\x20\x5b\x1\x65\x1\x7e\x1\x7a\x1\xa0\x0\xc7\x2\xd8\x2\x41\x1\xa4\x0\x4\x1\xa6\x0\xa7\x0\xa8\x0\xa9\x0\x5e\x1\xab\x0\xac\x0\xad\x0\xae\x0\x7b\x1\xb0\x0\xb1\x0\xdb\x2\x42\x1\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\x5\x1\x5f\x1\xbb\x0\x3d\x1\xdd\x2\x3e\x1\x7c\x1\x54\x1\xc1\x0\xc2\x0\x2\x1\xc4\x0\x39\x1\x6\x1\xc7\x0\xc\x1\xc9\x0\x18\x1\xcb\x0\x1a\x1\xcd\x0\xce\x0\xe\x1\x10\x1\x43\x1\x47\x1\xd3\x0\xd4\x0\x50\x1\xd6\x0\xd7\x0\x58\x1\x6e\x1\xda\x0\x70\x1\xdc\x0\xdd\x0\x62\x1\xdf\x0\x55\x1\xe1\x0\xe2\x0\x3\x1\xe4\x0\x3a\x1\x7\x1\xe7\x0\xd\x1\xe9\x0\x19\x1\xeb\x0\x1b\x1\xed\x0\xee\x0\xf\x1\x11\x1\x44\x1\x48\x1\xf3\x0\xf4\x0\x51\x1\xf6\x0\xf7\x0\x59\x1\x6f\x1\xfa\x0\x71\x1\xfc\x0\xfd\x0\x63\x1\xd9\x2"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x80\x1\x40\x2\x80\x1\x80\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\x0\xa4\x0\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\x0\xb0\xb1\x0\x0\xb4\xb5\xb6\xb7\xb8\x0\x0\xbb\x0\x0\x0\x0\x0\xc1\xc2\x0\xc4\x0\x0\xc7\x0\xc9\x0\xcb\x0\xcd\xce\x0\x0\x0\x0\xd3\xd4\x0\xd6\xd7\x0\x0\xda\x0\xdc\xdd\x0\xdf\x0\xe1\xe2\x0\xe4\x0\x0\xe7\x0\xe9\x0\xeb\x0\xed\xee\x0\x0\x0\x0\xf3\xf4\x0\xf6\xf7\x0\x0\xfa\x0\xfc\xfd\x0\x0\x0\x0\xc3\xe3\xa5\xb9\xc6\xe6\x0\x0\x0\x0\xc8\xe8\xcf\xef\xd0\xf0\x0\x0\x0\x0\x0\x0\xca\xea\xcc\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc5\xe5\x0\x0\xbc\xbe\x0\x0\xa3\xb3\xd1\xf1\x0\x0\xd2\xf2\x0\x0\x0\x0\x0\x0\x0\xd5\xf5\x0\x0\xc0\xe0\x0\x0\xd8\xf8\x8c\x9c\x0\x0\xaa\xba\x8a\x9a\xde\xfe\x8d\x9d\x0\x0\x0\x0\x0\x0\x0\x0\xd9\xf9\xdb\xfb\x0\x0\x0\x0\x0\x0\x0\x8f\x9f\xaf\xbf\x8e\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa2\xff\x0\xb2\x0\xbd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1251, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x2\x4\x3\x4\x1a\x20\x53\x4\x1e\x20\x26\x20\x20\x20\x21\x20\xac\x20\x30\x20\x9\x4\x39\x20\xa\x4\xc\x4\xb\x4\xf\x4\x52\x4\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x59\x4\x3a\x20\x5a\x4\x5c\x4\x5b\x4\x5f\x4\xa0\x0\xe\x4\x5e\x4\x8\x4\xa4\x0\x90\x4\xa6\x0\xa7\x0\x1\x4\xa9\x0\x4\x4\xab\x0\xac\x0\xad\x0\xae\x0\x7\x4\xb0\x0\xb1\x0\x6\x4\x56\x4\x91\x4\xb5\x0\xb6\x0\xb7\x0\x51\x4\x16\x21\x54\x4\xbb\x0\x58\x4\x5\x4\x55\x4\x57\x4\x10\x4\x11\x4\x12\x4\x13\x4\x14\x4\x15\x4\x16\x4\x17\x4\x18\x4\x19\x4\x1a\x4\x1b\x4\x1c\x4\x1d\x4\x1e\x4\x1f\x4\x20\x4\x21\x4\x22\x4\x23\x4\x24\x4\x25\x4\x26\x4\x27\x4\x28\x4\x29\x4\x2a\x4\x2b\x4\x2c\x4\x2d\x4\x2e\x4\x2f\x4\x30\x4\x31\x4\x32\x4\x33\x4\x34\x4\x35\x4\x36\x4\x37\x4\x38\x4\x39\x4\x3a\x4\x3b\x4\x3c\x4\x3d\x4\x3e\x4\x3f\x4\x40\x4\x41\x4\x42\x4\x43\x4\x44\x4\x45\x4\x46\x4\x47\x4\x48\x4\x49\x4\x4a\x4\x4b\x4\x4c\x4\x4d\x4\x4e\x4\x4f\x4"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\xc0\x0\x0\x2\xc0\x0\x40\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\x0\xa4\x0\xa6\xa7\x0\xa9\x0\xab\xac\xad\xae\x0\xb0\xb1\x0\x0\x0\xb5\xb6\xb7\x0\x0\x0\xbb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa8\x80\x81\xaa\xbd\xb2\xaf\xa3\x8a\x8c\x8e\x8d\x0\xa1\x8f\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x0\xb8\x90\x83\xba\xbe\xb3\xbf\xbc\x9a\x9c\x9e\x9d\x0\xa2\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa5\xb4\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xb9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1252, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x60\x1\x39\x20\x52\x1\x0\x0\x7d\x1\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x61\x1\x3a\x20\x53\x1\x0\x0\x7e\x1\x78\x1\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xaa\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xba\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xc0\x0\xc1\x0\xc2\x0\xc3\x0\xc4\x0\xc5\x0\xc6\x0\xc7\x0\xc8\x0\xc9\x0\xca\x0\xcb\x0\xcc\x0\xcd\x0\xce\x0\xcf\x0\xd0\x0\xd1\x0\xd2\x0\xd3\x0\xd4\x0\xd5\x0\xd6\x0\xd7\x0\xd8\x0\xd9\x0\xda\x0\xdb\x0\xdc\x0\xdd\x0\xde\x0\xdf\x0\xe0\x0\xe1\x0\xe2\x0\xe3\x0\xe4\x0\xe5\x0\xe6\x0\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\xec\x0\xed\x0\xee\x0\xef\x0\xf0\x0\xf1\x0\xf2\x0\xf3\x0\xf4\x0\xf5\x0\xf6\x0\xf7\x0\xf8\x0\xf9\x0\xfa\x0\xfb\x0\xfc\x0\xfd\x0\xfe\x0\xff\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x0\x1\x40\x2\x0\x1\x80\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8a\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x8e\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1253, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\x0\x0\x30\x20\x0\x0\x39\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x0\x0\x3a\x20\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x85\x3\x86\x3\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\x0\x0\xab\x0\xac\x0\xad\x0\xae\x0\x15\x20\xb0\x0\xb1\x0\xb2\x0\xb3\x0\x84\x3\xb5\x0\xb6\x0\xb7\x0\x88\x3\x89\x3\x8a\x3\xbb\x0\x8c\x3\xbd\x0\x8e\x3\x8f\x3\x90\x3\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\x98\x3\x99\x3\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x9e\x3\x9f\x3\xa0\x3\xa1\x3\x0\x0\xa3\x3\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xaa\x3\xab\x3\xac\x3\xad\x3\xae\x3\xaf\x3\xb0\x3\xb1\x3\xb2\x3\xb3\x3\xb4\x3\xb5\x3\xb6\x3\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc2\x3\xc3\x3\xc4\x3\xc5\x3\xc6\x3\xc7\x3\xc8\x3\xc9\x3\xca\x3\xcb\x3\xcc\x3\xcd\x3\xce\x3\x0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x40\x1\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\xc0\x0\x0\x2\xc0\x0\x40\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\xa3\xa4\xa5\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\x0\xb0\xb1\xb2\xb3\x0\xb5\xb6\xb7\x0\x0\x0\xbb\x0\xbd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xb4\xa1\xa2\x0\xb8\xb9\xba\x0\xbc\x0\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\x0\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\xaf\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1254, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x60\x1\x39\x20\x52\x1\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x61\x1\x3a\x20\x53\x1\x0\x0\x0\x0\x78\x1\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xaa\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xba\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xc0\x0\xc1\x0\xc2\x0\xc3\x0\xc4\x0\xc5\x0\xc6\x0\xc7\x0\xc8\x0\xc9\x0\xca\x0\xcb\x0\xcc\x0\xcd\x0\xce\x0\xcf\x0\x1e\x1\xd1\x0\xd2\x0\xd3\x0\xd4\x0\xd5\x0\xd6\x0\xd7\x0\xd8\x0\xd9\x0\xda\x0\xdb\x0\xdc\x0\x30\x1\x5e\x1\xdf\x0\xe0\x0\xe1\x0\xe2\x0\xe3\x0\xe4\x0\xe5\x0\xe6\x0\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\xec\x0\xed\x0\xee\x0\xef\x0\x1f\x1\xf1\x0\xf2\x0\xf3\x0\xf4\x0\xf5\x0\xf6\x0\xf7\x0\xf8\x0\xf9\x0\xfa\x0\xfb\x0\xfc\x0\x31\x1\x5f\x1\xff\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x0\x2\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x40\x2\xc0\x1\x80\x2\xc0\x1\xc0\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\x0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\x0\x0\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\x0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\x0\x0\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdd\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xde\xfe\x8a\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1255, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x0\x0\x39\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x0\x0\x3a\x20\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xaa\x20\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xd7\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xf7\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xb0\x5\xb1\x5\xb2\x5\xb3\x5\xb4\x5\xb5\x5\xb6\x5\xb7\x5\xb8\x5\xb9\x5\x0\x0\xbb\x5\xbc\x5\xbd\x5\xbe\x5\xbf\x5\xc0\x5\xc1\x5\xc2\x5\xc3\x5\xf0\x5\xf1\x5\xf2\x5\xf3\x5\xf4\x5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd0\x5\xd1\x5\xd2\x5\xd3\x5\xd4\x5\xd5\x5\xd6\x5\xd7\x5\xd8\x5\xd9\x5\xda\x5\xdb\x5\xdc\x5\xdd\x5\xde\x5\xdf\x5\xe0\x5\xe1\x5\xe2\x5\xe3\x5\xe4\x5\xe5\x5\xe6\x5\xe7\x5\xe8\x5\xe9\x5\xea\x5\x0\x0\x0\x0\xe\x20\xf\x20\x0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x0\x1\x80\x2\x0\x1\xc0\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\x0\xa5\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\x0\xbb\xbc\xbd\xbe\xbf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xaa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xba\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\x0\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\x0\x0\x0\x0\x0\xd4\xd5\xd6\xd7\xd8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfd\xfe\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa4\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1256, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x7e\x6\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x79\x6\x39\x20\x52\x1\x86\x6\x98\x6\x88\x6\xaf\x6\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xa9\x6\x22\x21\x91\x6\x3a\x20\x53\x1\xc\x20\xd\x20\xba\x6\xa0\x0\xc\x6\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xbe\x6\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\x1b\x6\xbb\x0\xbc\x0\xbd\x0\xbe\x0\x1f\x6\xc1\x6\x21\x6\x22\x6\x23\x6\x24\x6\x25\x6\x26\x6\x27\x6\x28\x6\x29\x6\x2a\x6\x2b\x6\x2c\x6\x2d\x6\x2e\x6\x2f\x6\x30\x6\x31\x6\x32\x6\x33\x6\x34\x6\x35\x6\x36\x6\xd7\x0\x37\x6\x38\x6\x39\x6\x3a\x6\x40\x6\x41\x6\x42\x6\x43\x6\xe0\x0\x44\x6\xe2\x0\x45\x6\x46\x6\x47\x6\x48\x6\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\x49\x6\x4a\x6\xee\x0\xef\x0\x4b\x6\x4c\x6\x4d\x6\x4e\x6\xf4\x0\x4f\x6\x50\x6\xf7\x0\x51\x6\xf9\x0\x52\x6\xfb\x0\xfc\x0\xe\x20\xf\x20\xd2\x6"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x3\x0\x1\x40\x3\x0\x1\x80\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\x0\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\x0\xbb\xbc\xbd\xbe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd7\x0\x0\x0\x0\x0\x0\x0\x0\xe0\x0\xe2\x0\x0\x0\x0\xe7\xe8\xe9\xea\xeb\x0\x0\xee\xef\x0\x0\x0\x0\xf4\x0\x0\xf7\x0\xf9\x0\xfb\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xba\x0\x0\x0\xbf\x0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd8\xd9\xda\xdb\x0\x0\x0\x0\x0\xdc\xdd\xde\xdf\xe1\xe3\xe4\xe5\xe6\xec\xed\xf0\xf1\xf2\xf3\xf5\xf6\xf8\xfa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8a\x0\x0\x0\x0\x81\x0\x0\x0\x0\x0\x0\x0\x8d\x0\x8f\x0\x0\x0\x0\x0\x0\x0\x0\x9a\x0\x0\x0\x0\x0\x0\x8e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x90\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\xaa\x0\x0\xc0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9d\x9e\xfd\xfe\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1257, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x0\x0\x1e\x20\x26\x20\x20\x20\x21\x20\x0\x0\x30\x20\x0\x0\x39\x20\x0\x0\xa8\x0\xc7\x2\xb8\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x22\x21\x0\x0\x3a\x20\x0\x0\xaf\x0\xdb\x2\x0\x0\xa0\x0\x0\x0\xa2\x0\xa3\x0\xa4\x0\x0\x0\xa6\x0\xa7\x0\xd8\x0\xa9\x0\x56\x1\xab\x0\xac\x0\xad\x0\xae\x0\xc6\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xf8\x0\xb9\x0\x57\x1\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xe6\x0\x4\x1\x2e\x1\x0\x1\x6\x1\xc4\x0\xc5\x0\x18\x1\x12\x1\xc\x1\xc9\x0\x79\x1\x16\x1\x22\x1\x36\x1\x2a\x1\x3b\x1\x60\x1\x43\x1\x45\x1\xd3\x0\x4c\x1\xd5\x0\xd6\x0\xd7\x0\x72\x1\x41\x1\x5a\x1\x6a\x1\xdc\x0\x7b\x1\x7d\x1\xdf\x0\x5\x1\x2f\x1\x1\x1\x7\x1\xe4\x0\xe5\x0\x19\x1\x13\x1\xd\x1\xe9\x0\x7a\x1\x17\x1\x23\x1\x37\x1\x2b\x1\x3c\x1\x61\x1\x44\x1\x46\x1\xf3\x0\x4d\x1\xf5\x0\xf6\x0\xf7\x0\x73\x1\x42\x1\x5b\x1\x6b\x1\xfc\x0\x7c\x1\x7e\x1\xd9\x2"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x80\x1\x40\x2\x80\x1\x80\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xa2\xa3\xa4\x0\xa6\xa7\x8d\xa9\x0\xab\xac\xad\xae\x9d\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\x8f\xb9\x0\xbb\xbc\xbd\xbe\x0\x0\x0\x0\x0\xc4\xc5\xaf\x0\x0\xc9\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd3\x0\xd5\xd6\xd7\xa8\x0\x0\x0\xdc\x0\x0\xdf\x0\x0\x0\x0\xe4\xe5\xbf\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf3\x0\xf5\xf6\xf7\xb8\x0\x0\x0\xfc\x0\x0\x0\xc2\xe2\x0\x0\xc0\xe0\xc3\xe3\x0\x0\x0\x0\xc8\xe8\x0\x0\x0\x0\xc7\xe7\x0\x0\xcb\xeb\xc6\xe6\x0\x0\x0\x0\x0\x0\x0\x0\xcc\xec\x0\x0\x0\x0\x0\x0\xce\xee\x0\x0\xc1\xe1\x0\x0\x0\x0\x0\x0\xcd\xed\x0\x0\x0\xcf\xef\x0\x0\x0\x0\xd9\xf9\xd1\xf1\xd2\xf2\x0\x0\x0\x0\x0\xd4\xf4\x0\x0\x0\x0\x0\x0\x0\x0\xaa\xba\x0\x0\xda\xfa\x0\x0\x0\x0\xd0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\xdb\xfb\x0\x0\x0\x0\x0\x0\xd8\xf8\x0\x0\x0\x0\x0\xca\xea\xdd\xfd\xde\xfe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (1258, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x1a\x20\x92\x1\x1e\x20\x26\x20\x20\x20\x21\x20\xc6\x2\x30\x20\x0\x0\x39\x20\x52\x1\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\xdc\x2\x22\x21\x0\x0\x3a\x20\x53\x1\x0\x0\x0\x0\x78\x1\xa0\x0\xa1\x0\xa2\x0\xa3\x0\xa4\x0\xa5\x0\xa6\x0\xa7\x0\xa8\x0\xa9\x0\xaa\x0\xab\x0\xac\x0\xad\x0\xae\x0\xaf\x0\xb0\x0\xb1\x0\xb2\x0\xb3\x0\xb4\x0\xb5\x0\xb6\x0\xb7\x0\xb8\x0\xb9\x0\xba\x0\xbb\x0\xbc\x0\xbd\x0\xbe\x0\xbf\x0\xc0\x0\xc1\x0\xc2\x0\x2\x1\xc4\x0\xc5\x0\xc6\x0\xc7\x0\xc8\x0\xc9\x0\xca\x0\xcb\x0\x0\x3\xcd\x0\xce\x0\xcf\x0\x10\x1\xd1\x0\x9\x3\xd3\x0\xd4\x0\xa0\x1\xd6\x0\xd7\x0\xd8\x0\xd9\x0\xda\x0\xdb\x0\xdc\x0\xaf\x1\x3\x3\xdf\x0\xe0\x0\xe1\x0\xe2\x0\x3\x1\xe4\x0\xe5\x0\xe6\x0\xe7\x0\xe8\x0\xe9\x0\xea\x0\xeb\x0\x1\x3\xed\x0\xee\x0\xef\x0\x11\x1\xf1\x0\x23\x3\xf3\x0\xf4\x0\xa1\x1\xf6\x0\xf7\x0\xf8\x0\xf9\x0\xfa\x0\xfb\x0\xfc\x0\xb0\x1\xab\x20\xff\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x0\x2\x40\x2\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\xc0\x1\x80\x2\xc0\x1\xc0\x2\xc0\x1\x0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\x0\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\x0\xcd\xce\xcf\x0\xd1\x0\xd3\xd4\x0\xd6\xd7\xd8\xd9\xda\xdb\xdc\x0\x0\xdf\xe0\xe1\xe2\x0\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\x0\xed\xee\xef\x0\xf1\x0\xf3\xf4\x0\xf6\xf7\xf8\xf9\xfa\xfb\xfc\x0\x0\xff\x0\x0\xc3\xe3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8c\x9c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x83\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd5\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdd\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcc\xec\x0\xde\x0\x0\x0\x0\x0\xd2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x82\x0\x93\x94\x84\x0\x86\x87\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x0\x8b\x9b\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe\x80\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x99"#-        , encoderMax = '\8482'-        }--   }-    )--    ,-    (437, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\xec\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\xff\x0\xd6\x0\xdc\x0\xa2\x0\xa3\x0\xa5\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x9b\x9c\x0\x9d\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\xaf\xac\xab\x0\xa8\x0\x0\x0\x0\x8e\x8f\x92\x80\x0\x90\x0\x0\x0\x0\x0\x0\x0\xa5\x0\x0\x0\x0\x99\x0\x0\x0\x0\x0\x9a\x0\x0\xe1\x85\xa0\x83\x0\x84\x86\x91\x87\x8a\x82\x88\x89\x8d\xa1\x8c\x8b\x0\xa4\x95\xa2\x93\x0\x94\xf6\x0\x97\xa3\x96\x81\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (500, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\xa0\x0\xe2\x0\xe4\x0\xe0\x0\xe1\x0\xe3\x0\xe5\x0\xe7\x0\xf1\x0\x5b\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x21\x0\x26\x0\xe9\x0\xea\x0\xeb\x0\xe8\x0\xed\x0\xee\x0\xef\x0\xec\x0\xdf\x0\x5d\x0\x24\x0\x2a\x0\x29\x0\x3b\x0\x5e\x0\x2d\x0\x2f\x0\xc2\x0\xc4\x0\xc0\x0\xc1\x0\xc3\x0\xc5\x0\xc7\x0\xd1\x0\xa6\x0\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xf8\x0\xc9\x0\xca\x0\xcb\x0\xc8\x0\xcd\x0\xce\x0\xcf\x0\xcc\x0\x60\x0\x3a\x0\x23\x0\x40\x0\x27\x0\x3d\x0\x22\x0\xd8\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xab\x0\xbb\x0\xf0\x0\xfd\x0\xfe\x0\xb1\x0\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xaa\x0\xba\x0\xe6\x0\xb8\x0\xc6\x0\xa4\x0\xb5\x0\x7e\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xa1\x0\xbf\x0\xd0\x0\xdd\x0\xde\x0\xae\x0\xa2\x0\xa3\x0\xa5\x0\xb7\x0\xa9\x0\xa7\x0\xb6\x0\xbc\x0\xbd\x0\xbe\x0\xac\x0\x7c\x0\xaf\x0\xa8\x0\xb4\x0\xd7\x0\x7b\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xf4\x0\xf6\x0\xf2\x0\xf3\x0\xf5\x0\x7d\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb9\x0\xfb\x0\xfc\x0\xf9\x0\xfa\x0\xff\x0\x5c\x0\xf7\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xd4\x0\xd6\x0\xd2\x0\xd3\x0\xd5\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xdb\x0\xdc\x0\xd9\x0\xda\x0\x9f\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f\x40\x4f\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\x4a\xe0\x5a\x5f\x6d\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\xbb\xd0\xa1\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x41\xaa\xb0\xb1\x9f\xb2\x6a\xb5\xbd\xb4\x9a\x8a\xba\xca\xaf\xbc\x90\x8f\xea\xfa\xbe\xa0\xb6\xb3\x9d\xda\x9b\x8b\xb7\xb8\xb9\xab\x64\x65\x62\x66\x63\x67\x9e\x68\x74\x71\x72\x73\x78\x75\x76\x77\xac\x69\xed\xee\xeb\xef\xec\xbf\x80\xfd\xfe\xfb\xfc\xad\xae\x59\x44\x45\x42\x46\x43\x47\x9c\x48\x54\x51\x52\x53\x58\x55\x56\x57\x8c\x49\xcd\xce\xcb\xcf\xcc\xe1\x70\xdd\xde\xdb\xdc\x8d\x8e\xdf"#-        , encoderMax = '\255'-        }--   }-    )--    ,-    (737, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\x98\x3\x99\x3\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x9e\x3\x9f\x3\xa0\x3\xa1\x3\xa3\x3\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xb1\x3\xb2\x3\xb3\x3\xb4\x3\xb5\x3\xb6\x3\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc3\x3\xc2\x3\xc4\x3\xc5\x3\xc6\x3\xc7\x3\xc8\x3\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xc9\x3\xac\x3\xad\x3\xae\x3\xca\x3\xaf\x3\xcc\x3\xcd\x3\xcb\x3\xce\x3\x86\x3\x88\x3\x89\x3\x8a\x3\x8c\x3\x8e\x3\x8f\x3\xb1\x0\x65\x22\x64\x22\xaa\x3\xab\x3\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf8\xf1\xfd\x0\x0\x0\x0\xfa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf6\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xea\x0\xeb\xec\xed\x0\xee\x0\xef\xf0\x0\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x0\x91\x92\x93\x94\x95\x96\x97\xf4\xf5\xe1\xe2\xe3\xe5\x0\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xaa\xa9\xab\xac\xad\xae\xaf\xe0\xe4\xe8\xe6\xe7\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (775, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x6\x1\xfc\x0\xe9\x0\x1\x1\xe4\x0\x23\x1\xe5\x0\x7\x1\x42\x1\x13\x1\x56\x1\x57\x1\x2b\x1\x79\x1\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\x4d\x1\xf6\x0\x22\x1\xa2\x0\x5a\x1\x5b\x1\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xd7\x0\xa4\x0\x0\x1\x2a\x1\xf3\x0\x7b\x1\x7c\x1\x7a\x1\x1d\x20\xa6\x0\xa9\x0\xae\x0\xac\x0\xbd\x0\xbc\x0\x41\x1\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x4\x1\xc\x1\x18\x1\x16\x1\x63\x25\x51\x25\x57\x25\x5d\x25\x2e\x1\x60\x1\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x72\x1\x6a\x1\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x7d\x1\x5\x1\xd\x1\x19\x1\x17\x1\x2f\x1\x61\x1\x73\x1\x6b\x1\x7e\x1\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xd3\x0\xdf\x0\x4c\x1\x43\x1\xf5\x0\xd5\x0\xb5\x0\x44\x1\x36\x1\x37\x1\x3b\x1\x3c\x1\x46\x1\x12\x1\x45\x1\x19\x20\xad\x0\xb1\x0\x1c\x20\xbe\x0\xb6\x0\xa7\x0\xf7\x0\x1e\x20\xb0\x0\x19\x22\xb7\x0\xb9\x0\xb3\x0\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x40\x2\x80\x2\xc0\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x96\x9c\x9f\x0\xa7\xf5\x0\xa8\x0\xae\xaa\xf0\xa9\x0\xf8\xf1\xfd\xfc\x0\xe6\xf4\xfa\x0\xfb\x0\xaf\xac\xab\xf3\x0\x0\x0\x0\x0\x8e\x8f\x92\x0\x0\x90\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe0\x0\xe5\x99\x9e\x9d\x0\x0\x0\x9a\x0\x0\xe1\x0\x0\x0\x0\x84\x86\x91\x0\x0\x82\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa2\x0\xe4\x94\xf6\x9b\x0\x0\x0\x81\x0\x0\x0\xa0\x83\x0\x0\xb5\xd0\x80\x87\x0\x0\x0\x0\xb6\xd1\x0\x0\x0\x0\xed\x89\x0\x0\xb8\xd3\xb7\xd2\x0\x0\x0\x0\x0\x0\x0\x0\x95\x85\x0\x0\x0\x0\x0\x0\xa1\x8c\x0\x0\xbd\xd4\x0\x0\x0\x0\x0\x0\xe8\xe9\x0\x0\x0\xea\xeb\x0\x0\x0\x0\xad\x88\xe3\xe7\xee\xec\x0\x0\x0\x0\x0\xe2\x93\x0\x0\x0\x0\x0\x0\x0\x0\x8a\x8b\x0\x0\x97\x98\x0\x0\x0\x0\xbe\xd5\x0\x0\x0\x0\x0\x0\x0\x0\xc7\xd7\x0\x0\x0\x0\x0\x0\xc6\xd6\x0\x0\x0\x0\x0\x8d\xa5\xa3\xa4\xcf\xd8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\xf2\xa6\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (850, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\xec\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\xff\x0\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xd7\x0\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\xae\x0\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\xc1\x0\xc2\x0\xc0\x0\xa9\x0\x63\x25\x51\x25\x57\x25\x5d\x25\xa2\x0\xa5\x0\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\xe3\x0\xc3\x0\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\xf0\x0\xd0\x0\xca\x0\xcb\x0\xc8\x0\x31\x1\xcd\x0\xce\x0\xcf\x0\x18\x25\xc\x25\x88\x25\x84\x25\xa6\x0\xcc\x0\x80\x25\xd3\x0\xdf\x0\xd4\x0\xd2\x0\xf5\x0\xd5\x0\xb5\x0\xfe\x0\xde\x0\xda\x0\xdb\x0\xd9\x0\xfd\x0\xdd\x0\xaf\x0\xb4\x0\xad\x0\xb1\x0\x17\x20\xbe\x0\xb6\x0\xa7\x0\xf7\x0\xb8\x0\xb0\x0\xa8\x0\xb7\x0\xb9\x0\xb3\x0\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\xc0\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x40\x1\x0\x2\x40\x2\x80\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\xbd\x9c\xcf\xbe\xdd\xf5\xf9\xb8\xa6\xae\xaa\xf0\xa9\xee\xf8\xf1\xfd\xfc\xef\xe6\xf4\xfa\xf7\xfb\xa7\xaf\xac\xab\xf3\xa8\xb7\xb5\xb6\xc7\x8e\x8f\x92\x80\xd4\x90\xd2\xd3\xde\xd6\xd7\xd8\xd1\xa5\xe3\xe0\xe2\xe5\x99\x9e\x9d\xeb\xe9\xea\x9a\xed\xe8\xe1\x85\xa0\x83\xc6\x84\x86\x91\x87\x8a\x82\x88\x89\x8d\xa1\x8c\x8b\xd0\xa4\x95\xa2\x93\xe4\x94\xf6\x9b\x97\xa3\x96\x81\xec\xe7\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xd5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (852, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\x6f\x1\x7\x1\xe7\x0\x42\x1\xeb\x0\x50\x1\x51\x1\xee\x0\x79\x1\xc4\x0\x6\x1\xc9\x0\x39\x1\x3a\x1\xf4\x0\xf6\x0\x3d\x1\x3e\x1\x5a\x1\x5b\x1\xd6\x0\xdc\x0\x64\x1\x65\x1\x41\x1\xd7\x0\xd\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\x4\x1\x5\x1\x7d\x1\x7e\x1\x18\x1\x19\x1\xac\x0\x7a\x1\xc\x1\x5f\x1\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\xc1\x0\xc2\x0\x1a\x1\x5e\x1\x63\x25\x51\x25\x57\x25\x5d\x25\x7b\x1\x7c\x1\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x2\x1\x3\x1\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\x11\x1\x10\x1\xe\x1\xcb\x0\xf\x1\x47\x1\xcd\x0\xce\x0\x1b\x1\x18\x25\xc\x25\x88\x25\x84\x25\x62\x1\x6e\x1\x80\x25\xd3\x0\xdf\x0\xd4\x0\x43\x1\x44\x1\x48\x1\x60\x1\x61\x1\x54\x1\xda\x0\x55\x1\x70\x1\xfd\x0\xdd\x0\x63\x1\xb4\x0\xad\x0\xdd\x2\xdb\x2\xc7\x2\xd8\x2\xa7\x0\xf7\x0\xb8\x0\xb0\x0\xa8\x0\xd9\x2\x71\x1\x58\x1\x59\x1\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x0\x2\x40\x2\x80\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\xcf\x0\x0\xf5\xf9\x0\x0\xae\xaa\xf0\x0\x0\xf8\x0\x0\x0\xef\x0\x0\x0\xf7\x0\x0\xaf\x0\x0\x0\x0\x0\xb5\xb6\x0\x8e\x0\x0\x80\x0\x90\x0\xd3\x0\xd6\xd7\x0\x0\x0\x0\xe0\xe2\x0\x99\x9e\x0\x0\xe9\x0\x9a\xed\x0\xe1\x0\xa0\x83\x0\x84\x0\x0\x87\x0\x82\x0\x89\x0\xa1\x8c\x0\x0\x0\x0\xa2\x93\x0\x94\xf6\x0\x0\xa3\x0\x81\xec\x0\x0\x0\x0\xc6\xc7\xa4\xa5\x8f\x86\x0\x0\x0\x0\xac\x9f\xd2\xd4\xd1\xd0\x0\x0\x0\x0\x0\x0\xa8\xa9\xb7\xd8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x91\x92\x0\x0\x95\x96\x0\x0\x9d\x88\xe3\xe4\x0\x0\xd5\xe5\x0\x0\x0\x0\x0\x0\x0\x8a\x8b\x0\x0\xe8\xea\x0\x0\xfc\xfd\x97\x98\x0\x0\xb8\xad\xe6\xe7\xdd\xee\x9b\x9c\x0\x0\x0\x0\x0\x0\x0\x0\xde\x85\xeb\xfb\x0\x0\x0\x0\x0\x0\x0\x8d\xab\xbd\xbe\xa6\xa7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xfa\x0\xf2\x0\xf1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (855, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x52\x4\x2\x4\x53\x4\x3\x4\x51\x4\x1\x4\x54\x4\x4\x4\x55\x4\x5\x4\x56\x4\x6\x4\x57\x4\x7\x4\x58\x4\x8\x4\x59\x4\x9\x4\x5a\x4\xa\x4\x5b\x4\xb\x4\x5c\x4\xc\x4\x5e\x4\xe\x4\x5f\x4\xf\x4\x4e\x4\x2e\x4\x4a\x4\x2a\x4\x30\x4\x10\x4\x31\x4\x11\x4\x46\x4\x26\x4\x34\x4\x14\x4\x35\x4\x15\x4\x44\x4\x24\x4\x33\x4\x13\x4\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x45\x4\x25\x4\x38\x4\x18\x4\x63\x25\x51\x25\x57\x25\x5d\x25\x39\x4\x19\x4\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x3a\x4\x1a\x4\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\x3b\x4\x1b\x4\x3c\x4\x1c\x4\x3d\x4\x1d\x4\x3e\x4\x1e\x4\x3f\x4\x18\x25\xc\x25\x88\x25\x84\x25\x1f\x4\x4f\x4\x80\x25\x2f\x4\x40\x4\x20\x4\x41\x4\x21\x4\x42\x4\x22\x4\x43\x4\x23\x4\x36\x4\x16\x4\x32\x4\x12\x4\x4c\x4\x2c\x4\x16\x21\xad\x0\x4b\x4\x2b\x4\x37\x4\x17\x4\x48\x4\x28\x4\x4d\x4\x2d\x4\x49\x4\x29\x4\x47\x4\x27\x4\xa7\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\x0\x2\x40\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\xcf\x0\x0\xfd\x0\x0\x0\xae\x0\xf0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xaf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x85\x81\x83\x87\x89\x8b\x8d\x8f\x91\x93\x95\x97\x0\x99\x9b\xa1\xa3\xec\xad\xa7\xa9\xea\xf4\xb8\xbe\xc7\xd1\xd3\xd5\xd7\xdd\xe2\xe4\xe6\xe8\xab\xb6\xa5\xfc\xf6\xfa\x9f\xf2\xee\xf8\x9d\xe0\xa0\xa2\xeb\xac\xa6\xa8\xe9\xf3\xb7\xbd\xc6\xd0\xd2\xd4\xd6\xd8\xe1\xe3\xe5\xe7\xaa\xb5\xa4\xfb\xf5\xf9\x9e\xf1\xed\xf7\x9c\xde\x0\x84\x80\x82\x86\x88\x8a\x8c\x8e\x90\x92\x94\x96\x0\x98\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (857, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\x31\x1\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\x30\x1\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\x5e\x1\x5f\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\x1e\x1\x1f\x1\xbf\x0\xae\x0\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\xc1\x0\xc2\x0\xc0\x0\xa9\x0\x63\x25\x51\x25\x57\x25\x5d\x25\xa2\x0\xa5\x0\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\xe3\x0\xc3\x0\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa4\x0\xba\x0\xaa\x0\xca\x0\xcb\x0\xc8\x0\x0\x0\xcd\x0\xce\x0\xcf\x0\x18\x25\xc\x25\x88\x25\x84\x25\xa6\x0\xcc\x0\x80\x25\xd3\x0\xdf\x0\xd4\x0\xd2\x0\xf5\x0\xd5\x0\xb5\x0\x0\x0\xd7\x0\xda\x0\xdb\x0\xd9\x0\xec\x0\xff\x0\xaf\x0\xb4\x0\xad\x0\xb1\x0\x0\x0\xbe\x0\xb6\x0\xa7\x0\xf7\x0\xb8\x0\xb0\x0\xa8\x0\xb7\x0\xb9\x0\xb3\x0\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x40\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\x80\x1\xc0\x1\x0\x2\x40\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\xbd\x9c\xcf\xbe\xdd\xf5\xf9\xb8\xd1\xae\xaa\xf0\xa9\xee\xf8\xf1\xfd\xfc\xef\xe6\xf4\xfa\xf7\xfb\xd0\xaf\xac\xab\xf3\xa8\xb7\xb5\xb6\xc7\x8e\x8f\x92\x80\xd4\x90\xd2\xd3\xde\xd6\xd7\xd8\x0\xa5\xe3\xe0\xe2\xe5\x99\xe8\x9d\xeb\xe9\xea\x9a\x0\x0\xe1\x85\xa0\x83\xc6\x84\x86\x91\x87\x8a\x82\x88\x89\xec\xa1\x8c\x8b\x0\xa4\x95\xa2\x93\xe4\x94\xf6\x9b\x97\xa3\x96\x81\x0\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa6\xa7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x98\x8d\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (860, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe3\x0\xe0\x0\xc1\x0\xe7\x0\xea\x0\xca\x0\xe8\x0\xcd\x0\xd4\x0\xec\x0\xc3\x0\xc2\x0\xc9\x0\xc0\x0\xc8\x0\xf4\x0\xf5\x0\xf2\x0\xda\x0\xf9\x0\xcc\x0\xd5\x0\xdc\x0\xa2\x0\xa3\x0\xd9\x0\xa7\x20\xd3\x0\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\xd2\x0\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x80\x2\x0\x1\x0\x1\xc0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x3\x40\x3\x80\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x9b\x9c\x0\x0\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\xaf\xac\xab\x0\xa8\x91\x86\x8f\x8e\x0\x0\x0\x80\x92\x90\x89\x0\x98\x8b\x0\x0\x0\xa5\xa9\x9f\x8c\x99\x0\x0\x0\x9d\x96\x0\x9a\x0\x0\xe1\x85\xa0\x83\x84\x0\x0\x0\x87\x8a\x82\x88\x0\x8d\xa1\x0\x0\x0\xa4\x95\xa2\x93\x94\x0\xf6\x0\x97\xa3\x0\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (861, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xd0\x0\xf0\x0\xde\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xfe\x0\xfb\x0\xdd\x0\xfd\x0\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xc1\x0\xcd\x0\xd3\x0\xda\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x0\x9c\x0\x0\x0\x0\x0\x0\x0\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\x0\xaf\xac\xab\x0\xa8\x0\xa4\x0\x0\x8e\x8f\x92\x80\x0\x90\x0\x0\x0\xa5\x0\x0\x8b\x0\x0\xa6\x0\x0\x99\x0\x9d\x0\xa7\x0\x9a\x97\x8d\xe1\x85\xa0\x83\x0\x84\x86\x91\x87\x8a\x82\x88\x89\x0\xa1\x0\x0\x8c\x0\x0\xa2\x93\x0\x94\xf6\x9b\x0\xa3\x96\x81\x98\x95\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (862, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xd0\x5\xd1\x5\xd2\x5\xd3\x5\xd4\x5\xd5\x5\xd6\x5\xd7\x5\xd8\x5\xd9\x5\xda\x5\xdb\x5\xdc\x5\xdd\x5\xde\x5\xdf\x5\xe0\x5\xe1\x5\xe2\x5\xe3\x5\xe4\x5\xe5\x5\xe6\x5\xe7\x5\xe8\x5\xe9\x5\xea\x5\xa2\x0\xa3\x0\xa5\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x80\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x2\x0\x3\x0\x1\x0\x1\x40\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x3\xc0\x3\x0\x4"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x9b\x9c\x0\x9d\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\xaf\xac\xab\x0\xa8\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe1\x0\xa0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\x0\x0\x0\xa4\x0\xa2\x0\x0\x0\xf6\x0\x0\xa3\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (863, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xc2\x0\xe0\x0\xb6\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\x17\x20\xc0\x0\xa7\x0\xc9\x0\xc8\x0\xca\x0\xf4\x0\xcb\x0\xcf\x0\xfb\x0\xf9\x0\xa4\x0\xd4\x0\xdc\x0\xa2\x0\xa3\x0\xd9\x0\xdb\x0\x92\x1\xa6\x0\xb4\x0\xf3\x0\xfa\x0\xa8\x0\xb8\x0\xb3\x0\xaf\x0\xce\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xbe\x0\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x9b\x9c\x98\x0\xa0\x8f\xa4\x0\x0\xae\xaa\x0\x0\xa7\xf8\xf1\xfd\xa6\xa1\xe6\x86\xfa\xa5\x0\x0\xaf\xac\xab\xad\x0\x8e\x0\x84\x0\x0\x0\x0\x80\x91\x90\x92\x94\x0\x0\xa8\x95\x0\x0\x0\x0\x99\x0\x0\x0\x0\x9d\x0\x9e\x9a\x0\x0\xe1\x85\x0\x83\x0\x0\x0\x0\x87\x8a\x82\x88\x89\x0\x0\x8c\x8b\x0\x0\x0\xa2\x93\x0\x0\xf6\x0\x97\xa3\x96\x81\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8d\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (864, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x6a\x6\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xb0\x0\xb7\x0\x19\x22\x1a\x22\x92\x25\x0\x25\x2\x25\x3c\x25\x24\x25\x2c\x25\x1c\x25\x34\x25\x10\x25\xc\x25\x14\x25\x18\x25\xb2\x3\x1e\x22\xc6\x3\xb1\x0\xbd\x0\xbc\x0\x48\x22\xab\x0\xbb\x0\xf7\xfe\xf8\xfe\x0\x0\x0\x0\xfb\xfe\xfc\xfe\x0\x0\xa0\x0\xad\x0\x82\xfe\xa3\x0\xa4\x0\x84\xfe\x0\x0\x0\x0\x8e\xfe\x8f\xfe\x95\xfe\x99\xfe\xc\x6\x9d\xfe\xa1\xfe\xa5\xfe\x60\x6\x61\x6\x62\x6\x63\x6\x64\x6\x65\x6\x66\x6\x67\x6\x68\x6\x69\x6\xd1\xfe\x1b\x6\xb1\xfe\xb5\xfe\xb9\xfe\x1f\x6\xa2\x0\x80\xfe\x81\xfe\x83\xfe\x85\xfe\xca\xfe\x8b\xfe\x8d\xfe\x91\xfe\x93\xfe\x97\xfe\x9b\xfe\x9f\xfe\xa3\xfe\xa7\xfe\xa9\xfe\xab\xfe\xad\xfe\xaf\xfe\xb3\xfe\xb7\xfe\xbb\xfe\xbf\xfe\xc1\xfe\xc5\xfe\xcb\xfe\xcf\xfe\xa6\x0\xac\x0\xf7\x0\xd7\x0\xc9\xfe\x40\x6\xd3\xfe\xd7\xfe\xdb\xfe\xdf\xfe\xe3\xfe\xe7\xfe\xeb\xfe\xed\xfe\xef\xfe\xf3\xfe\xbd\xfe\xcc\xfe\xce\xfe\xcd\xfe\xe1\xfe\x7d\xfe\x51\x6\xe5\xfe\xe9\xfe\xec\xfe\xf0\xfe\xf2\xfe\xd0\xfe\xd5\xfe\xf5\xfe\xf6\xfe\xdd\xfe\xd9\xfe\xf1\xfe\xa0\x25\x0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x1\x80\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x1\x0\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x2\x80\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\xc0\x2\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x0\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\xc0\xa3\xa4\x0\xdb\x0\x0\x0\x0\x97\xdc\xa1\x0\x0\x80\x93\x0\x0\x0\x0\x0\x81\x0\x0\x0\x98\x95\x94\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xde\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x90\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x92\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xac\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xbb\x0\x0\x0\xbf\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf1\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\x25\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x82\x83\x0\x0\x0\x91\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x85\x0\x86\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8d\x0\x0\x0\x8c\x0\x0\x0\x8e\x0\x0\x0\x8f\x0\x0\x0\x8a\x0\x0\x0\x0\x0\x0\x0\x88\x0\x0\x0\x0\x0\x0\x0\x89\x0\x0\x0\x0\x0\x0\x0\x8b\x0\x0\x0\x0\x0\x0\x0\x87\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x84\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xc1\xc2\xa2\xc3\xa5\xc4\x0\x0\x0\x0\x0\xc6\x0\xc7\xa8\xa9\x0\xc8\x0\xc9\x0\xaa\x0\xca\x0\xab\x0\xcb\x0\xad\x0\xcc\x0\xae\x0\xcd\x0\xaf\x0\xce\x0\xcf\x0\xd0\x0\xd1\x0\xd2\x0\xbc\x0\xd3\x0\xbd\x0\xd4\x0\xbe\x0\xd5\x0\xeb\x0\xd6\x0\xd7\x0\x0\x0\xd8\x0\x0\x0\xdf\xc5\xd9\xec\xee\xed\xda\xf7\xba\x0\xe1\x0\xf8\x0\xe2\x0\xfc\x0\xe3\x0\xfb\x0\xe4\x0\xef\x0\xe5\x0\xf2\x0\xe6\x0\xf3\x0\xe7\xf4\xe8\x0\xe9\xf5\xfd\xf6\xea\x0\xf9\xfa\x99\x9a\x0\x0\x9d\x9e"#-        , encoderMax = '\65276'-        }--   }-    )--    ,-    (865, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xc7\x0\xfc\x0\xe9\x0\xe2\x0\xe4\x0\xe0\x0\xe5\x0\xe7\x0\xea\x0\xeb\x0\xe8\x0\xef\x0\xee\x0\xec\x0\xc4\x0\xc5\x0\xc9\x0\xe6\x0\xc6\x0\xf4\x0\xf6\x0\xf2\x0\xfb\x0\xf9\x0\xff\x0\xd6\x0\xdc\x0\xf8\x0\xa3\x0\xd8\x0\xa7\x20\x92\x1\xe1\x0\xed\x0\xf3\x0\xfa\x0\xf1\x0\xd1\x0\xaa\x0\xba\x0\xbf\x0\x10\x23\xac\x0\xbd\x0\xbc\x0\xa1\x0\xab\x0\xa4\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\xb1\x3\xdf\x0\x93\x3\xc0\x3\xa3\x3\xc3\x3\xb5\x0\xc4\x3\xa6\x3\x98\x3\xa9\x3\xb4\x3\x1e\x22\xc6\x3\xb5\x3\x29\x22\x61\x22\xb1\x0\x65\x22\x64\x22\x20\x23\x21\x23\xf7\x0\x48\x22\xb0\x0\x19\x22\xb7\x0\x1a\x22\x7f\x20\xb2\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\x0\x1\x0\x1\x40\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x1\xc0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x2\x40\x2\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x80\x2\xc0\x2\x0\x1\x0\x1\x0\x3\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x0\x1\x40\x3\x80\x3\xc0\x3"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\xad\x0\x9c\xaf\x0\x0\x0\x0\x0\xa6\xae\xaa\x0\x0\x0\xf8\xf1\xfd\x0\x0\xe6\x0\xfa\x0\x0\xa7\x0\xac\xab\x0\xa8\x0\x0\x0\x0\x8e\x8f\x92\x80\x0\x90\x0\x0\x0\x0\x0\x0\x0\xa5\x0\x0\x0\x0\x99\x0\x9d\x0\x0\x0\x9a\x0\x0\xe1\x85\xa0\x83\x0\x84\x86\x91\x87\x8a\x82\x88\x89\x8d\xa1\x8c\x8b\x0\xa4\x95\xa2\x93\x0\x94\xf6\x9b\x97\xa3\x96\x81\x0\x0\x98\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe2\x0\x0\x0\x0\xe9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe4\x0\x0\xe8\x0\x0\xea\x0\x0\x0\x0\x0\x0\x0\xe0\x0\x0\xeb\xee\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xe3\x0\x0\xe5\xe7\x0\xed\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x9e\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\xec\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf3\xf2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf4\xf5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (866, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x10\x4\x11\x4\x12\x4\x13\x4\x14\x4\x15\x4\x16\x4\x17\x4\x18\x4\x19\x4\x1a\x4\x1b\x4\x1c\x4\x1d\x4\x1e\x4\x1f\x4\x20\x4\x21\x4\x22\x4\x23\x4\x24\x4\x25\x4\x26\x4\x27\x4\x28\x4\x29\x4\x2a\x4\x2b\x4\x2c\x4\x2d\x4\x2e\x4\x2f\x4\x30\x4\x31\x4\x32\x4\x33\x4\x34\x4\x35\x4\x36\x4\x37\x4\x38\x4\x39\x4\x3a\x4\x3b\x4\x3c\x4\x3d\x4\x3e\x4\x3f\x4\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x61\x25\x62\x25\x56\x25\x55\x25\x63\x25\x51\x25\x57\x25\x5d\x25\x5c\x25\x5b\x25\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\x5e\x25\x5f\x25\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\x67\x25\x68\x25\x64\x25\x65\x25\x59\x25\x58\x25\x52\x25\x53\x25\x6b\x25\x6a\x25\x18\x25\xc\x25\x88\x25\x84\x25\x8c\x25\x90\x25\x80\x25\x40\x4\x41\x4\x42\x4\x43\x4\x44\x4\x45\x4\x46\x4\x47\x4\x48\x4\x49\x4\x4a\x4\x4b\x4\x4c\x4\x4d\x4\x4e\x4\x4f\x4\x1\x4\x51\x4\x4\x4\x54\x4\x7\x4\x57\x4\xe\x4\x5e\x4\xb0\x0\x19\x22\xb7\x0\x1a\x22\x16\x21\xa4\x0\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x2\x40\x2\x80\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x0\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf8\x0\x0\x0\x0\x0\x0\xfa\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf0\x0\x0\xf2\x0\x0\xf4\x0\x0\x0\x0\x0\x0\xf6\x0\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\x0\xf1\x0\x0\xf3\x0\x0\xf5\x0\x0\x0\x0\x0\x0\xf7\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfc\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xf9\xfb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\xd5\xd6\xc9\xb8\xb7\xbb\xd4\xd3\xc8\xbe\xbd\xbc\xc6\xc7\xcc\xb5\xb6\xb9\xd1\xd2\xcb\xcf\xd0\xca\xd8\xd7\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\xdd\x0\x0\x0\xde\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (869, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x86\x3\x0\x0\xb7\x0\xac\x0\xa6\x0\x18\x20\x19\x20\x88\x3\x15\x20\x89\x3\x8a\x3\xaa\x3\x8c\x3\x0\x0\x0\x0\x8e\x3\xab\x3\xa9\x0\x8f\x3\xb2\x0\xb3\x0\xac\x3\xa3\x0\xad\x3\xae\x3\xaf\x3\xca\x3\x90\x3\xcc\x3\xcd\x3\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\xbd\x0\x98\x3\x99\x3\xab\x0\xbb\x0\x91\x25\x92\x25\x93\x25\x2\x25\x24\x25\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x63\x25\x51\x25\x57\x25\x5d\x25\x9e\x3\x9f\x3\x10\x25\x14\x25\x34\x25\x2c\x25\x1c\x25\x0\x25\x3c\x25\xa0\x3\xa1\x3\x5a\x25\x54\x25\x69\x25\x66\x25\x60\x25\x50\x25\x6c\x25\xa3\x3\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xb1\x3\xb2\x3\xb3\x3\x18\x25\xc\x25\x88\x25\x84\x25\xb4\x3\xb5\x3\x80\x25\xb6\x3\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc3\x3\xc2\x3\xc4\x3\x84\x3\xad\x0\xb1\x0\xc5\x3\xc6\x3\xc7\x3\xa7\x0\xc8\x3\x85\x3\xb0\x0\xa8\x0\xc9\x3\xcb\x3\xb0\x3\xce\x3\xa0\x25\xa0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x1\x0\x2\x40\x2"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xff\x0\x0\x9c\x0\x0\x8a\xf5\xf9\x97\x0\xae\x89\xf0\x0\x0\xf8\xf1\x99\x9a\x0\x0\x0\x88\x0\x0\x0\xaf\x0\xab\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xef\xf7\x86\x0\x8d\x8f\x90\x0\x92\x0\x95\x98\xa1\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xac\xad\xb5\xb6\xb7\xb8\xbd\xbe\xc6\xc7\x0\xcf\xd0\xd1\xd2\xd3\xd4\xd5\x91\x96\x9b\x9d\x9e\x9f\xfc\xd6\xd7\xd8\xdd\xde\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xed\xec\xee\xf2\xf3\xf4\xf6\xfa\xa0\xfb\xa2\xa3\xfd\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x8e\x0\x0\x8b\x8c\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xc4\x0\xb3\x0\x0\x0\x0\x0\x0\x0\x0\x0\xda\x0\x0\x0\xbf\x0\x0\x0\xc0\x0\x0\x0\xd9\x0\x0\x0\xc3\x0\x0\x0\x0\x0\x0\x0\xb4\x0\x0\x0\x0\x0\x0\x0\xc2\x0\x0\x0\x0\x0\x0\x0\xc1\x0\x0\x0\x0\x0\x0\x0\xc5\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcd\xba\x0\x0\xc9\x0\x0\xbb\x0\x0\xc8\x0\x0\xbc\x0\x0\xcc\x0\x0\xb9\x0\x0\xcb\x0\x0\xca\x0\x0\xce\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xdf\x0\x0\x0\xdc\x0\x0\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\xb0\xb1\xb2\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xfe"#-        , encoderMax = '\9632'-        }--   }-    )--    ,-    (874, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x4\x0\x5\x0\x6\x0\x7\x0\x8\x0\x9\x0\xa\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x14\x0\x15\x0\x16\x0\x17\x0\x18\x0\x19\x0\x1a\x0\x1b\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x20\x0\x21\x0\x22\x0\x23\x0\x24\x0\x25\x0\x26\x0\x27\x0\x28\x0\x29\x0\x2a\x0\x2b\x0\x2c\x0\x2d\x0\x2e\x0\x2f\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\x3a\x0\x3b\x0\x3c\x0\x3d\x0\x3e\x0\x3f\x0\x40\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\x5b\x0\x5c\x0\x5d\x0\x5e\x0\x5f\x0\x60\x0\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\x7b\x0\x7c\x0\x7d\x0\x7e\x0\x7f\x0\xac\x20\x0\x0\x0\x0\x0\x0\x0\x0\x26\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x18\x20\x19\x20\x1c\x20\x1d\x20\x22\x20\x13\x20\x14\x20\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x1\xe\x2\xe\x3\xe\x4\xe\x5\xe\x6\xe\x7\xe\x8\xe\x9\xe\xa\xe\xb\xe\xc\xe\xd\xe\xe\xe\xf\xe\x10\xe\x11\xe\x12\xe\x13\xe\x14\xe\x15\xe\x16\xe\x17\xe\x18\xe\x19\xe\x1a\xe\x1b\xe\x1c\xe\x1d\xe\x1e\xe\x1f\xe\x20\xe\x21\xe\x22\xe\x23\xe\x24\xe\x25\xe\x26\xe\x27\xe\x28\xe\x29\xe\x2a\xe\x2b\xe\x2c\xe\x2d\xe\x2e\xe\x2f\xe\x30\xe\x31\xe\x32\xe\x33\xe\x34\xe\x35\xe\x36\xe\x37\xe\x38\xe\x39\xe\x3a\xe\x0\x0\x0\x0\x0\x0\x0\x0\x3f\xe\x40\xe\x41\xe\x42\xe\x43\xe\x44\xe\x45\xe\x46\xe\x47\xe\x48\xe\x49\xe\x4a\xe\x4b\xe\x4c\xe\x4d\xe\x4e\xe\x4f\xe\x50\xe\x51\xe\x52\xe\x53\xe\x54\xe\x55\xe\x56\xe\x57\xe\x58\xe\x59\xe\x5a\xe\x5b\xe\x0\x0\x0\x0\x0\x0\x0\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1\xc0\x0\xc0\x1"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\x0\x0\x0\x0\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x96\x97\x0\x0\x0\x91\x92\x0\x0\x93\x94\x0\x0\x0\x0\x95\x0\x0\x0\x85\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80"#-        , encoderMax = '\8364'-        }--   }-    )--    ,-    (875, SingleByteCP {-     decoderArray = ConvArray "\x0\x0\x1\x0\x2\x0\x3\x0\x9c\x0\x9\x0\x86\x0\x7f\x0\x97\x0\x8d\x0\x8e\x0\xb\x0\xc\x0\xd\x0\xe\x0\xf\x0\x10\x0\x11\x0\x12\x0\x13\x0\x9d\x0\x85\x0\x8\x0\x87\x0\x18\x0\x19\x0\x92\x0\x8f\x0\x1c\x0\x1d\x0\x1e\x0\x1f\x0\x80\x0\x81\x0\x82\x0\x83\x0\x84\x0\xa\x0\x17\x0\x1b\x0\x88\x0\x89\x0\x8a\x0\x8b\x0\x8c\x0\x5\x0\x6\x0\x7\x0\x90\x0\x91\x0\x16\x0\x93\x0\x94\x0\x95\x0\x96\x0\x4\x0\x98\x0\x99\x0\x9a\x0\x9b\x0\x14\x0\x15\x0\x9e\x0\x1a\x0\x20\x0\x91\x3\x92\x3\x93\x3\x94\x3\x95\x3\x96\x3\x97\x3\x98\x3\x99\x3\x5b\x0\x2e\x0\x3c\x0\x28\x0\x2b\x0\x21\x0\x26\x0\x9a\x3\x9b\x3\x9c\x3\x9d\x3\x9e\x3\x9f\x3\xa0\x3\xa1\x3\xa3\x3\x5d\x0\x24\x0\x2a\x0\x29\x0\x3b\x0\x5e\x0\x2d\x0\x2f\x0\xa4\x3\xa5\x3\xa6\x3\xa7\x3\xa8\x3\xa9\x3\xaa\x3\xab\x3\x7c\x0\x2c\x0\x25\x0\x5f\x0\x3e\x0\x3f\x0\xa8\x0\x86\x3\x88\x3\x89\x3\xa0\x0\x8a\x3\x8c\x3\x8e\x3\x8f\x3\x60\x0\x3a\x0\x23\x0\x40\x0\x27\x0\x3d\x0\x22\x0\x85\x3\x61\x0\x62\x0\x63\x0\x64\x0\x65\x0\x66\x0\x67\x0\x68\x0\x69\x0\xb1\x3\xb2\x3\xb3\x3\xb4\x3\xb5\x3\xb6\x3\xb0\x0\x6a\x0\x6b\x0\x6c\x0\x6d\x0\x6e\x0\x6f\x0\x70\x0\x71\x0\x72\x0\xb7\x3\xb8\x3\xb9\x3\xba\x3\xbb\x3\xbc\x3\xb4\x0\x7e\x0\x73\x0\x74\x0\x75\x0\x76\x0\x77\x0\x78\x0\x79\x0\x7a\x0\xbd\x3\xbe\x3\xbf\x3\xc0\x3\xc1\x3\xc3\x3\xa3\x0\xac\x3\xad\x3\xae\x3\xca\x3\xaf\x3\xcc\x3\xcd\x3\xcb\x3\xce\x3\xc2\x3\xc4\x3\xc5\x3\xc6\x3\xc7\x3\xc8\x3\x7b\x0\x41\x0\x42\x0\x43\x0\x44\x0\x45\x0\x46\x0\x47\x0\x48\x0\x49\x0\xad\x0\xc9\x3\x90\x3\xb0\x3\x18\x20\x15\x20\x7d\x0\x4a\x0\x4b\x0\x4c\x0\x4d\x0\x4e\x0\x4f\x0\x50\x0\x51\x0\x52\x0\xb1\x0\xbd\x0\x1a\x0\x87\x3\x19\x20\xa6\x0\x5c\x0\x1a\x0\x53\x0\x54\x0\x55\x0\x56\x0\x57\x0\x58\x0\x59\x0\x5a\x0\xb2\x0\xa7\x0\x1a\x0\x1a\x0\xab\x0\xac\x0\x30\x0\x31\x0\x32\x0\x33\x0\x34\x0\x35\x0\x36\x0\x37\x0\x38\x0\x39\x0\xb3\x0\xa9\x0\x1a\x0\x1a\x0\xbb\x0\x9f\x0"#-     , encoderArray = - CompactArray {-        encoderIndices = ConvArray "\x0\x0\x40\x0\x80\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x0\x1\x40\x1\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\xc0\x0\x80\x1"#-        , encoderValues = ConvArray "\x0\x1\x2\x3\x37\x2d\x2e\x2f\x16\x5\x25\xb\xc\xd\xe\xf\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\xfd\x27\x1c\x1d\x1e\x1f\x40\x4f\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\x4a\xe0\x5a\x5f\x6d\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\x6a\xd0\xa1\x7\x20\x21\x22\x23\x24\x15\x6\x17\x28\x29\x2a\x2b\x2c\x9\xa\x1b\x30\x31\x1a\x33\x34\x35\x36\x8\x38\x39\x3a\x3b\x4\x14\x3e\xff\x74\x0\x0\xb0\x0\x0\xdf\xeb\x70\xfb\x0\xee\xef\xca\x0\x0\x90\xda\xea\xfa\xa0\x0\x0\x0\x0\x0\x0\xfe\x0\xdb\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x80\x71\xdd\x72\x73\x75\x0\x76\x0\x77\x78\xcc\x41\x42\x43\x44\x45\x46\x47\x48\x49\x51\x52\x53\x54\x55\x56\x57\x58\x0\x59\x62\x63\x64\x65\x66\x67\x68\x69\xb1\xb2\xb3\xb5\xcd\x8a\x8b\x8c\x8d\x8e\x8f\x9a\x9b\x9c\x9d\x9e\x9f\xaa\xab\xac\xad\xae\xba\xaf\xbb\xbc\xbd\xbe\xbf\xcb\xb4\xb8\xb6\xb7\xb9\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\x0\xcf\x0\x0\xce\xde"#-        , encoderMax = '\8217'-        }--   }-    )-    ]
− GHC/IO/Encoding/Failure.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.Failure--- Copyright   :  (c) The University of Glasgow, 2008-2011--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Types for specifying how text encoding/decoding fails-----------------------------------------------------------------------------------module GHC.IO.Encoding.Failure (-    CodingFailureMode(..), codingFailureModeSuffix,-    isSurrogate,-    recoverDecode, recoverEncode-  ) where--import GHC.IO-import GHC.IO.Buffer-import GHC.IO.Exception--import GHC.Base-import GHC.Char-import GHC.Word-import GHC.Show-import GHC.Num-import GHC.Real ( fromIntegral )----import System.Posix.Internals---- | The 'CodingFailureMode' is used to construct 'System.IO.TextEncoding's,--- and specifies how they handle illegal sequences.-data CodingFailureMode-  = ErrorOnCodingFailure-       -- ^ Throw an error when an illegal sequence is encountered-  | IgnoreCodingFailure-       -- ^ Attempt to ignore and recover if an illegal sequence is-       -- encountered-  | TransliterateCodingFailure-       -- ^ Replace with the closest visual match upon an illegal-       -- sequence-  | RoundtripFailure-       -- ^ Use the private-use escape mechanism to attempt to allow-       -- illegal sequences to be roundtripped.-  deriving ( Show -- ^ @since 4.4.0.0-           )-       -- This will only work properly for those encodings which are-       -- strict supersets of ASCII in the sense that valid ASCII data-       -- is also valid in that encoding. This is not true for-       -- e.g. UTF-16, because ASCII characters must be padded to two-       -- bytes to retain their meaning.---- Note [Roundtripping]--- ~~~~~~~~~~~~~~~~~~~~------ Roundtripping is based on the ideas of PEP383.------ We used to use the range of private-use characters from 0xEF80 to--- 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registery--- to encode these characters.------ However, people didn't like this because it means we don't get--- guaranteed roundtripping for byte sequences that look like a UTF-8--- encoded codepoint 0xEFxx.------ So now like PEP383 we use lone surrogate codepoints 0xDCxx to escape--- undecodable bytes, even though that may confuse Unicode processing--- software written in Haskell. This guarantees roundtripping because--- 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 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 had--- to do the inverse process.------ The user of String would never see these lone surrogates, but it--- 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       = ""-codingFailureModeSuffix IgnoreCodingFailure        = "//IGNORE"-codingFailureModeSuffix TransliterateCodingFailure = "//TRANSLIT"-codingFailureModeSuffix RoundtripFailure           = "//ROUNDTRIP"---- | In transliterate mode, we use this character when decoding--- unknown bytes.------ This is the defined Unicode replacement character:--- <http://www.fileformat.info/info/unicode/char/0fffd/index.htm>-unrepresentableChar :: Char-unrepresentableChar = '\xFFFD'---- It is extraordinarily important that this series of--- predicates/transformers gets inlined, because they tend to be used--- in inner loops related to text encoding. In particular,--- surrogatifyRoundtripCharacter must be inlined (see #5536)---- | Some characters are actually "surrogate" codepoints defined for--- use in UTF-16. We need to signal an invalid character if we detect--- them when encoding a sequence of 'Char's into 'Word8's because they--- won't give valid Unicode.------ We may also need to signal an invalid character if we detect them--- when encoding a sequence of 'Char's into 'Word8's because the--- 'RoundtripFailure' mode creates these to round-trip bytes through--- our internal UTF-16 encoding.-{-# INLINE isSurrogate #-}-isSurrogate :: Char -> Bool-isSurrogate c = (0xD800 <= x && x <= 0xDBFF)-             || (0xDC00 <= x && x <= 0xDFFF)-  where x = ord c---- Bytes (in Buffer Word8) --> lone surrogates (in Buffer CharBufElem)-{-# INLINE escapeToRoundtripCharacterSurrogate #-}-escapeToRoundtripCharacterSurrogate :: Word8 -> Char-escapeToRoundtripCharacterSurrogate b-  | b < 128   = chr (fromIntegral b)-      -- Disallow 'smuggling' of ASCII bytes. For roundtripping to-      -- work, this assumes encoding is ASCII-superset.-  | otherwise = chr (0xDC00 + fromIntegral b)---- Lone surrogates (in Buffer CharBufElem) --> bytes (in Buffer Word8)-{-# INLINE unescapeRoundtripCharacterSurrogate #-}-unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8-unescapeRoundtripCharacterSurrogate c-    | 0xDC80 <= x && x < 0xDD00 = Just (fromIntegral x) -- Discard high byte-    | otherwise                 = Nothing-  where x = ord c--recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char-              -> IO (Buffer Word8, Buffer Char)-recoverDecode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }-                  output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } =- --puts $ "recoverDecode " ++ show ir- case cfm of-  ErrorOnCodingFailure       -> ioe_decodingError-  IgnoreCodingFailure        -> return (input { bufL=ir+1 }, output)-  TransliterateCodingFailure -> do-      ow' <- writeCharBuf oraw ow unrepresentableChar-      return (input { bufL=ir+1 }, output { bufR=ow' })-  RoundtripFailure           -> do-      b <- readWord8Buf iraw ir-      ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b)-      return (input { bufL=ir+1 }, output { bufR=ow' })--recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8-              -> IO (Buffer Char, Buffer Word8)-recoverEncode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }-                  output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } = do-  (c,ir') <- readCharBuf iraw ir-  --puts $ "recoverEncode " ++ show ir ++ " " ++ show ir'-  case cfm of-    IgnoreCodingFailure        -> return (input { bufL=ir' }, output)-    TransliterateCodingFailure -> do-        if c == '?'-         then return (input { bufL=ir' }, output)-         else do-          -- XXX: evil hack! To implement transliteration, we just-          -- poke an ASCII ? into the input buffer and tell the caller-          -- to try and decode again. This is *probably* safe given-          -- current uses of TextEncoding.-          ---          -- The "if" test above ensures we skip if the encoding fails-          -- to deal with the ?, though this should never happen in-          -- practice as all encodings are in fact capable of-          -- reperesenting all ASCII characters.-          _ir' <- writeCharBuf iraw ir '?'-          return (input, output)--        -- This implementation does not work because e.g. UTF-16-        -- requires 2 bytes to encode a simple ASCII value-        --writeWord8Buf oraw ow unrepresentableByte-        --return (input { bufL=ir' }, output { bufR=ow+1 })-    RoundtripFailure | Just x <- unescapeRoundtripCharacterSurrogate c -> do-        writeWord8Buf oraw ow x-        return (input { bufL=ir' }, output { bufR=ow+1 })-    _                          -> ioe_encodingError--ioe_decodingError :: IO a-ioe_decodingError = ioException-    (IOError Nothing InvalidArgument "recoverDecode"-        "invalid byte sequence" Nothing Nothing)--ioe_encodingError :: IO a-ioe_encodingError = ioException-    (IOError Nothing InvalidArgument "recoverEncode"-        "invalid character" Nothing Nothing)-
− GHC/IO/Encoding/Iconv.hs 
@@ -1,201 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , NondecreasingIndentation-  #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.Iconv--- Copyright   :  (c) The University of Glasgow, 2008-2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ This module provides text encoding/decoding using iconv-----------------------------------------------------------------------------------module GHC.IO.Encoding.Iconv (-#if !defined(mingw32_HOST_OS)-   iconvEncoding, mkIconvEncoding,-   localeEncodingName-#endif- ) where--#include "MachDeps.h"-#include "HsBaseConfig.h"--#if defined(mingw32_HOST_OS)-import GHC.Base () -- For build ordering-#else--import Foreign-import Foreign.C hiding (charIsRepresentable)-import Data.Maybe-import GHC.Base-import GHC.Foreign (charIsRepresentable)-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-import GHC.List (span)-import GHC.Num-import GHC.Show-import GHC.Real-import System.IO.Unsafe (unsafePerformIO)-import System.Posix.Internals--c_DEBUG_DUMP :: Bool-c_DEBUG_DUMP = False--iconv_trace :: String -> IO ()-iconv_trace s- | c_DEBUG_DUMP = puts s- | otherwise    = return ()---- -------------------------------------------------------------------------------- iconv encoders/decoders--{-# NOINLINE localeEncodingName #-}-localeEncodingName :: String-localeEncodingName = unsafePerformIO $ do-   -- Use locale_charset() or nl_langinfo(CODESET) to get the encoding-   -- if we have either of them.-   cstr <- c_localeEncoding-   peekCAString cstr -- Assume charset names are ASCII---- We hope iconv_t is a storable type.  It should be, since it has at least the--- value -1, which is a possible return value from iconv_open.-type IConv = CLong -- ToDo: (#type iconv_t)--foreign import ccall unsafe "hs_iconv_open"-    hs_iconv_open :: CString -> CString -> IO IConv--foreign import ccall unsafe "hs_iconv_close"-    hs_iconv_close :: IConv -> IO CInt--foreign import ccall unsafe "hs_iconv"-    hs_iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize-          -> IO CSize--foreign import ccall unsafe "localeEncoding"-    c_localeEncoding :: IO CString--haskellChar :: String-#if defined(WORDS_BIGENDIAN)-haskellChar | charSize == 2 = "UTF-16BE"-            | otherwise     = "UTF-32BE"-#else-haskellChar | charSize == 2 = "UTF-16LE"-            | otherwise     = "UTF-32LE"-#endif--char_shift :: Int-char_shift | charSize == 2 = 1-           | otherwise     = 2--iconvEncoding :: String -> IO (Maybe TextEncoding)-iconvEncoding = mkIconvEncoding ErrorOnCodingFailure---- | Construct an iconv-based 'TextEncoding' for the given character set and--- 'CodingFailureMode'.------ As iconv is missing in some minimal environments (e.g. #10298), this--- checks to ensure that iconv is working properly before returning the--- encoding, returning 'Nothing' if not.-mkIconvEncoding :: CodingFailureMode -> String -> IO (Maybe TextEncoding)-mkIconvEncoding cfm charset = do-    let enc = TextEncoding {-                  textEncodingName = charset,-                  mkTextDecoder = newIConv raw_charset (haskellChar ++ suffix)-                                           (recoverDecode cfm) iconvDecode,-                  mkTextEncoder = newIConv haskellChar charset-                                           (recoverEncode cfm) iconvEncode}-    good <- charIsRepresentable enc 'a'-    return $ if good-               then Just enc-               else Nothing-  where-    -- An annoying feature of GNU iconv is that the //PREFIXES only take-    -- effect when they appear on the tocode parameter to iconv_open:-    (raw_charset, suffix) = span (/= '/') charset--newIConv :: String -> String-   -> (Buffer a -> Buffer b -> IO (Buffer a, Buffer b))-   -> (IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b))-   -> IO (BufferCodec a b ())-newIConv from to rec fn =-  -- Assume charset names are ASCII-  withCAString from $ \ from_str ->-  withCAString to   $ \ to_str -> do-    iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str-    let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt-    return BufferCodec{-                encode = fn iconvt,-                recover = rec,-                close  = iclose,-                -- iconv doesn't supply a way to save/restore the state-                getState = return (),-                setState = const $ return ()-                }--iconvDecode :: IConv -> DecodeBuffer-iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift--iconvEncode :: IConv -> EncodeBuffer-iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0--iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int-            -> IO (CodingProgress, Buffer a, Buffer b)-iconvRecode iconv_t-  input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_  }  iscale-  output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow, bufSize=os }  oscale-  = do-    iconv_trace ("haskellChar=" ++ show haskellChar)-    iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input))-    iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output))-    withRawBuffer iraw $ \ piraw -> do-    withRawBuffer oraw $ \ poraw -> do-    with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do-    with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do-    with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do-    with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do-      res <- hs_iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft-      new_inleft  <- peek p_inleft-      new_outleft <- peek p_outleft-      let-          new_inleft'  = fromIntegral new_inleft `shiftR` iscale-          new_outleft' = fromIntegral new_outleft `shiftR` oscale-          new_input-            | new_inleft == 0  = input { bufL = 0, bufR = 0 }-            | otherwise        = input { bufL = iw - new_inleft' }-          new_output = output{ bufR = os - new_outleft' }-      iconv_trace ("iconv res=" ++ show res)-      iconv_trace ("iconvRecode after,  input=" ++ show (summaryBuffer new_input))-      iconv_trace ("iconvRecode after,  output=" ++ show (summaryBuffer new_output))-      if (res /= -1)-        then -- all input translated-           return (InputUnderflow, new_input, new_output)-        else do-      errno <- getErrno-      case errno of-        e | e == e2BIG  -> return (OutputUnderflow, new_input, new_output)-          | e == eINVAL -> return (InputUnderflow, new_input, new_output)-           -- Sometimes iconv reports EILSEQ for a-           -- character in the input even when there is no room-           -- in the output; in this case we might be about to-           -- change the encoding anyway, so the following bytes-           -- could very well be in a different encoding.-           ---           -- Because we can only say InvalidSequence if there is at least-           -- one element left in the output, we have to special case this.-          | e == eILSEQ -> return (if new_outleft' == 0 then OutputUnderflow else InvalidSequence, new_input, new_output)-          | otherwise -> do-              iconv_trace ("iconv returned error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))-              throwErrno "iconvRecoder"--#endif /* !mingw32_HOST_OS */-
− GHC/IO/Encoding/Latin1.hs 
@@ -1,230 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , BangPatterns-           , NondecreasingIndentation-  #-}-{-# OPTIONS_GHC  -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.Latin1--- Copyright   :  (c) The University of Glasgow, 2009--- License     :  see libraries/base/LICENSE--- --- Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Single-byte encodings that map directly to Unicode code points.------ Portions Copyright   : (c) Tom Harper 2008-2009,---                        (c) Bryan O'Sullivan 2009,---                        (c) Duncan Coutts 2009-----------------------------------------------------------------------------------module GHC.IO.Encoding.Latin1 (-  latin1, mkLatin1,-  latin1_checked, mkLatin1_checked,-  ascii, mkAscii,-  latin1_decode,-  ascii_decode,-  latin1_encode,-  latin1_checked_encode,-  ascii_encode,-  ) where--import GHC.Base-import GHC.Real-import GHC.Num--- import GHC.IO-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types---- -------------------------------------------------------------------------------- Latin1--latin1 :: TextEncoding-latin1 = mkLatin1 ErrorOnCodingFailure---- | @since 4.4.0.0-mkLatin1 :: CodingFailureMode -> TextEncoding-mkLatin1 cfm = TextEncoding { textEncodingName = "ISO-8859-1",-                              mkTextDecoder = latin1_DF cfm,-                              mkTextEncoder = latin1_EF cfm }--latin1_DF :: CodingFailureMode -> IO (TextDecoder ())-latin1_DF cfm =-  return (BufferCodec {-             encode   = latin1_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--latin1_EF :: CodingFailureMode -> IO (TextEncoder ())-latin1_EF cfm =-  return (BufferCodec {-             encode   = latin1_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--latin1_checked :: TextEncoding-latin1_checked = mkLatin1_checked ErrorOnCodingFailure---- | @since 4.4.0.0-mkLatin1_checked :: CodingFailureMode -> TextEncoding-mkLatin1_checked cfm = TextEncoding { textEncodingName = "ISO-8859-1",-                                      mkTextDecoder = latin1_DF cfm,-                                      mkTextEncoder = latin1_checked_EF cfm }--latin1_checked_EF :: CodingFailureMode -> IO (TextEncoder ())-latin1_checked_EF cfm =-  return (BufferCodec {-             encode   = latin1_checked_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })---- -------------------------------------------------------------------------------- ASCII---- | @since 4.9.0.0-ascii :: TextEncoding-ascii = mkAscii ErrorOnCodingFailure---- | @since 4.9.0.0-mkAscii :: CodingFailureMode -> TextEncoding-mkAscii cfm = TextEncoding { textEncodingName = "ASCII",-                             mkTextDecoder = ascii_DF cfm,-                             mkTextEncoder = ascii_EF cfm }--ascii_DF :: CodingFailureMode -> IO (TextDecoder ())-ascii_DF cfm =-  return (BufferCodec {-             encode   = ascii_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--ascii_EF :: CodingFailureMode -> IO (TextEncoder ())-ascii_EF cfm =-  return (BufferCodec {-             encode   = ascii_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })------ -------------------------------------------------------------------------------- The actual decoders and encoders---- TODO: Eliminate code duplication between the checked and unchecked--- versions of the decoder or encoder (but don't change the Core!)--latin1_decode :: DecodeBuffer-latin1_decode -  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let -       loop !ir !ow-         | ow >= os = done OutputUnderflow ir ow-         | ir >= iw = done InputUnderflow ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))-              loop (ir+1) ow'--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-    in-    loop ir0 ow0--ascii_decode :: DecodeBuffer-ascii_decode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-       loop !ir !ow-         | ow >= os = done OutputUnderflow ir ow-         | ir >= iw = done InputUnderflow ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              if c0 > 0x7f then invalid else do-              ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))-              loop (ir+1) ow'-         where-           invalid = done InvalidSequence ir ow--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-    in-    loop ir0 ow0--latin1_encode :: EncodeBuffer-latin1_encode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ow >= os = done OutputUnderflow ir ow-        | ir >= iw = done InputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           writeWord8Buf oraw ow (fromIntegral (ord c))-           loop ir' (ow+1)-    in-    loop ir0 ow0--latin1_checked_encode :: EncodeBuffer-latin1_checked_encode input output- = single_byte_checked_encode 0xff input output--ascii_encode :: EncodeBuffer-ascii_encode input output- = single_byte_checked_encode 0x7f input output--single_byte_checked_encode :: Int -> EncodeBuffer-single_byte_checked_encode max_legal_char-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ow >= os = done OutputUnderflow ir ow-        | ir >= iw = done InputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           if ord c > max_legal_char then invalid else do-           writeWord8Buf oraw ow (fromIntegral (ord c))-           loop ir' (ow+1)-        where-           invalid = done InvalidSequence ir ow-    in-    loop ir0 ow0-{-# INLINE single_byte_checked_encode #-}
− GHC/IO/Encoding/Types.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.Types--- Copyright   :  (c) The University of Glasgow, 2008-2009--- License     :  see libraries/base/LICENSE--- --- Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Types for text encoding/decoding-----------------------------------------------------------------------------------module GHC.IO.Encoding.Types (-    BufferCodec(..),-    TextEncoding(..),-    TextEncoder, TextDecoder,-    CodeBuffer, EncodeBuffer, DecodeBuffer,-    CodingProgress(..)-  ) where--import GHC.Base-import GHC.Word-import GHC.Show--- import GHC.IO-import GHC.IO.Buffer---- -------------------------------------------------------------------------------- Text encoders/decoders--data BufferCodec from to state = BufferCodec {-  encode :: CodeBuffer from to,-   -- ^ The @encode@ function translates elements of the buffer @from@-   -- to the buffer @to@.  It should translate as many elements as possible-   -- given the sizes of the buffers, including translating zero elements-   -- if there is either not enough room in @to@, or @from@ does not-   -- contain a complete multibyte sequence.-   ---   -- If multiple CodingProgress returns are possible, OutputUnderflow must be-   -- preferred to InvalidSequence. This allows GHC's IO library to assume that-   -- if we observe InvalidSequence there is at least a single element available-   -- in the output buffer.-   ---   -- The fact that as many elements as possible are translated is used by the IO-   -- library in order to report translation errors at the point they-   -- actually occur, rather than when the buffer is translated.-  -  recover :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to),-   -- ^ The @recover@ function is used to continue decoding-   -- in the presence of invalid or unrepresentable sequences. This includes-   -- both those detected by @encode@ returning @InvalidSequence@ and those-   -- that occur because the input byte sequence appears to be truncated.-   ---   -- Progress will usually be made by skipping the first element of the @from@-   -- buffer. This function should only be called if you are certain that you-   -- wish to do this skipping and if the @to@ buffer has at least one element-   -- of free space. Because this function deals with decoding failure, it assumes-   -- that the from buffer has at least one element.-   ---   -- @recover@ may raise an exception rather than skipping anything.-   ---   -- Currently, some implementations of @recover@ may mutate the input buffer.-   -- In particular, this feature is used to implement transliteration.-   ---   -- @since 4.4.0.0-  -  close  :: IO (),-   -- ^ Resources associated with the encoding may now be released.-   -- The @encode@ function may not be called again after calling-   -- @close@.--  getState :: IO state,-   -- ^ Return the current state of the codec.-   ---   -- Many codecs are not stateful, and in these case the state can be-   -- represented as '()'.  Other codecs maintain a state.  For-   -- example, UTF-16 recognises a BOM (byte-order-mark) character at-   -- the beginning of the input, and remembers thereafter whether to-   -- use big-endian or little-endian mode.  In this case, the state-   -- of the codec would include two pieces of information: whether we-   -- are at the beginning of the stream (the BOM only occurs at the-   -- beginning), and if not, whether to use the big or little-endian-   -- encoding.--  setState :: state -> IO ()-   -- restore the state of the codec using the state from a previous-   -- call to 'getState'.- }--type CodeBuffer from to = Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to)-type DecodeBuffer = CodeBuffer Word8 Char-type EncodeBuffer = CodeBuffer Char Word8--type TextDecoder state = BufferCodec Word8 CharBufElem state-type TextEncoder state = BufferCodec CharBufElem Word8 state---- | A 'TextEncoding' is a specification of a conversion scheme--- between sequences of bytes and sequences of Unicode characters.------ For example, UTF-8 is an encoding of Unicode characters into a sequence--- of bytes.  The 'TextEncoding' for UTF-8 is 'System.IO.utf8'.-data TextEncoding-  = forall dstate estate . TextEncoding  {-        textEncodingName :: String,-                   -- ^ a string that can be passed to 'System.IO.mkTextEncoding' to-                   -- create an equivalent 'TextEncoding'.-        mkTextDecoder :: IO (TextDecoder dstate),-                   -- ^ Creates a means of decoding bytes into characters: the result must not-                   -- be shared between several byte sequences or simultaneously across threads-        mkTextEncoder :: IO (TextEncoder estate)-                   -- ^ Creates a means of encode characters into bytes: the result must not-                   -- be shared between several character sequences or simultaneously across threads-  }---- | @since 4.3.0.0-instance Show TextEncoding where-  -- | Returns the value of 'textEncodingName'-  show te = textEncodingName te---- | @since 4.4.0.0-data CodingProgress = InputUnderflow  -- ^ Stopped because the input contains insufficient available elements,-                                      -- 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-                                      -- an invalid or unrepresentable sequence-                    deriving ( Eq   -- ^ @since 4.4.0.0-                             , Show -- ^ @since 4.4.0.0-                             )-
− GHC/IO/Encoding/UTF16.hs 
@@ -1,358 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , BangPatterns-           , NondecreasingIndentation-           , MagicHash-  #-}-{-# OPTIONS_GHC  -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.UTF16--- Copyright   :  (c) The University of Glasgow, 2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ UTF-16 Codecs for the IO library------ Portions Copyright   : (c) Tom Harper 2008-2009,---                        (c) Bryan O'Sullivan 2009,---                        (c) Duncan Coutts 2009-----------------------------------------------------------------------------------module GHC.IO.Encoding.UTF16 (-  utf16, mkUTF16,-  utf16_decode,-  utf16_encode,--  utf16be, mkUTF16be,-  utf16be_decode,-  utf16be_encode,--  utf16le, mkUTF16le,-  utf16le_decode,-  utf16le_encode,-  ) where--import GHC.Base-import GHC.Real-import GHC.Num--- import GHC.IO-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-import GHC.Word-import Data.Bits-import GHC.IORef---- -------------------------------------------------------------------------------- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM--utf16  :: TextEncoding-utf16 = mkUTF16 ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF16 :: CodingFailureMode -> TextEncoding-mkUTF16 cfm =  TextEncoding { textEncodingName = "UTF-16",-                              mkTextDecoder = utf16_DF cfm,-                              mkTextEncoder = utf16_EF cfm }--utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer))-utf16_DF cfm = do-  seen_bom <- newIORef Nothing-  return (BufferCodec {-             encode   = utf16_decode seen_bom,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = readIORef seen_bom,-             setState = writeIORef seen_bom-          })--utf16_EF :: CodingFailureMode -> IO (TextEncoder Bool)-utf16_EF cfm = do-  done_bom <- newIORef False-  return (BufferCodec {-             encode   = utf16_encode done_bom,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = readIORef done_bom,-             setState = writeIORef done_bom-          })--utf16_encode :: IORef Bool -> EncodeBuffer-utf16_encode done_bom input-  output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }- = do-  b <- readIORef done_bom-  if b then utf16_native_encode input output-       else if os - ow < 2-               then return (OutputUnderflow,input,output)-               else do-                    writeIORef done_bom True-                    writeWord8Buf oraw ow     bom1-                    writeWord8Buf oraw (ow+1) bom2-                    utf16_native_encode input output{ bufR = ow+2 }--utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer-utf16_decode seen_bom-  input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }-  output- = do-   mb <- readIORef seen_bom-   case mb of-     Just decode -> decode input output-     Nothing ->-       if iw - ir < 2 then return (InputUnderflow,input,output) else do-       c0 <- readWord8Buf iraw ir-       c1 <- readWord8Buf iraw (ir+1)-       case () of-        _ | c0 == bomB && c1 == bomL -> do-               writeIORef seen_bom (Just utf16be_decode)-               utf16be_decode input{ bufL= ir+2 } output-          | c0 == bomL && c1 == bomB -> do-               writeIORef seen_bom (Just utf16le_decode)-               utf16le_decode input{ bufL= ir+2 } output-          | otherwise -> do-               writeIORef seen_bom (Just utf16_native_decode)-               utf16_native_decode input output---bomB, bomL, bom1, bom2 :: Word8-bomB = 0xfe-bomL = 0xff---- choose UTF-16BE by default for UTF-16 output-utf16_native_decode :: DecodeBuffer-utf16_native_decode = utf16be_decode--utf16_native_encode :: EncodeBuffer-utf16_native_encode = utf16be_encode--bom1 = bomB-bom2 = bomL---- -------------------------------------------------------------------------------- UTF16LE and UTF16BE--utf16be :: TextEncoding-utf16be = mkUTF16be ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF16be :: CodingFailureMode -> TextEncoding-mkUTF16be cfm = TextEncoding { textEncodingName = "UTF-16BE",-                               mkTextDecoder = utf16be_DF cfm,-                               mkTextEncoder = utf16be_EF cfm }--utf16be_DF :: CodingFailureMode -> IO (TextDecoder ())-utf16be_DF cfm =-  return (BufferCodec {-             encode   = utf16be_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf16be_EF :: CodingFailureMode -> IO (TextEncoder ())-utf16be_EF cfm =-  return (BufferCodec {-             encode   = utf16be_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf16le :: TextEncoding-utf16le = mkUTF16le ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF16le :: CodingFailureMode -> TextEncoding-mkUTF16le cfm = TextEncoding { textEncodingName = "UTF16-LE",-                               mkTextDecoder = utf16le_DF cfm,-                               mkTextEncoder = utf16le_EF cfm }--utf16le_DF :: CodingFailureMode -> IO (TextDecoder ())-utf16le_DF cfm =-  return (BufferCodec {-             encode   = utf16le_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf16le_EF :: CodingFailureMode -> IO (TextEncoder ())-utf16le_EF cfm =-  return (BufferCodec {-             encode   = utf16le_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })---utf16be_decode :: DecodeBuffer-utf16be_decode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-       loop !ir !ow-         | ow >= os     = done OutputUnderflow ir ow-         | ir >= iw     = done InputUnderflow ir ow-         | ir + 1 == iw = done InputUnderflow ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              c1 <- readWord8Buf iraw (ir+1)-              let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1-              if validate1 x1-                 then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1))-                         loop (ir+2) ow'-                 else if iw - ir < 4 then done InputUnderflow ir ow else do-                      c2 <- readWord8Buf iraw (ir+2)-                      c3 <- readWord8Buf iraw (ir+3)-                      let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3-                      if not (validate2 x1 x2) then invalid else do-                      ow' <- writeCharBuf oraw ow (chr2 x1 x2)-                      loop (ir+4) ow'-         where-           invalid = done InvalidSequence ir ow--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-    in-    loop ir0 ow0--utf16le_decode :: DecodeBuffer-utf16le_decode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-       loop !ir !ow-         | ow >= os     = done OutputUnderflow ir ow-         | ir >= iw     = done InputUnderflow ir ow-         | ir + 1 == iw = done InputUnderflow ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              c1 <- readWord8Buf iraw (ir+1)-              let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0-              if validate1 x1-                 then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1))-                         loop (ir+2) ow'-                 else if iw - ir < 4 then done InputUnderflow ir ow else do-                      c2 <- readWord8Buf iraw (ir+2)-                      c3 <- readWord8Buf iraw (ir+3)-                      let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2-                      if not (validate2 x1 x2) then invalid else do-                      ow' <- writeCharBuf oraw ow (chr2 x1 x2)-                      loop (ir+4) ow'-         where-           invalid = done InvalidSequence ir ow--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-    in-    loop ir0 ow0--utf16be_encode :: EncodeBuffer-utf16be_encode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ir >= iw     =  done InputUnderflow ir ow-        | os - ow < 2  =  done OutputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           case ord c of-             x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do-                    writeWord8Buf oraw ow     (fromIntegral (x `shiftR` 8))-                    writeWord8Buf oraw (ow+1) (fromIntegral x)-                    loop ir' (ow+2)-               | otherwise -> do-                    if os - ow < 4 then done OutputUnderflow ir ow else do-                    let-                         n1 = x - 0x10000-                         c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)-                         c2 = fromIntegral (n1 `shiftR` 10)-                         n2 = n1 .&. 0x3FF-                         c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)-                         c4 = fromIntegral n2-                    ---                    writeWord8Buf oraw ow     c1-                    writeWord8Buf oraw (ow+1) c2-                    writeWord8Buf oraw (ow+2) c3-                    writeWord8Buf oraw (ow+3) c4-                    loop ir' (ow+4)-    in-    loop ir0 ow0--utf16le_encode :: EncodeBuffer-utf16le_encode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ir >= iw     =  done InputUnderflow ir ow-        | os - ow < 2  =  done OutputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           case ord c of-             x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do-                    writeWord8Buf oraw ow     (fromIntegral x)-                    writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))-                    loop ir' (ow+2)-               | otherwise ->-                    if os - ow < 4 then done OutputUnderflow ir ow else do-                    let-                         n1 = x - 0x10000-                         c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)-                         c2 = fromIntegral (n1 `shiftR` 10)-                         n2 = n1 .&. 0x3FF-                         c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)-                         c4 = fromIntegral n2-                    ---                    writeWord8Buf oraw ow     c2-                    writeWord8Buf oraw (ow+1) c1-                    writeWord8Buf oraw (ow+2) c4-                    writeWord8Buf oraw (ow+3) c3-                    loop ir' (ow+4)-    in-    loop ir0 ow0--chr2 :: Word16 -> Word16 -> Char-chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#))-    where-      !x# = word2Int# (word16ToWord# a#)-      !y# = word2Int# (word16ToWord# b#)-      !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10#-      !lower# = y# -# 0xDC00#-{-# INLINE chr2 #-}--validate1    :: Word16 -> Bool-validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF-{-# INLINE validate1 #-}--validate2       ::  Word16 -> Word16 -> Bool-validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF &&-                  x2 >= 0xDC00 && x2 <= 0xDFFF-{-# INLINE validate2 #-}
− GHC/IO/Encoding/UTF32.hs 
@@ -1,335 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , BangPatterns-           , NondecreasingIndentation-           , MagicHash-  #-}-{-# OPTIONS_GHC  -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.UTF32--- Copyright   :  (c) The University of Glasgow, 2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ UTF-32 Codecs for the IO library------ Portions Copyright   : (c) Tom Harper 2008-2009,---                        (c) Bryan O'Sullivan 2009,---                        (c) Duncan Coutts 2009-----------------------------------------------------------------------------------module GHC.IO.Encoding.UTF32 (-  utf32, mkUTF32,-  utf32_decode,-  utf32_encode,--  utf32be, mkUTF32be,-  utf32be_decode,-  utf32be_encode,--  utf32le, mkUTF32le,-  utf32le_decode,-  utf32le_encode,-  ) where--import GHC.Base-import GHC.Real-import GHC.Num--- import GHC.IO-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-import GHC.Word-import Data.Bits-import GHC.IORef---- -------------------------------------------------------------------------------- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM--utf32  :: TextEncoding-utf32 = mkUTF32 ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF32 :: CodingFailureMode -> TextEncoding-mkUTF32 cfm = TextEncoding { textEncodingName = "UTF-32",-                             mkTextDecoder = utf32_DF cfm,-                             mkTextEncoder = utf32_EF cfm }--utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer))-utf32_DF cfm = do-  seen_bom <- newIORef Nothing-  return (BufferCodec {-             encode   = utf32_decode seen_bom,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = readIORef seen_bom,-             setState = writeIORef seen_bom-          })--utf32_EF :: CodingFailureMode -> IO (TextEncoder Bool)-utf32_EF cfm = do-  done_bom <- newIORef False-  return (BufferCodec {-             encode   = utf32_encode done_bom,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = readIORef done_bom,-             setState = writeIORef done_bom-          })--utf32_encode :: IORef Bool -> EncodeBuffer-utf32_encode done_bom input-  output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }- = do-  b <- readIORef done_bom-  if b then utf32_native_encode input output-       else if os - ow < 4-               then return (OutputUnderflow, input,output)-               else do-                    writeIORef done_bom True-                    writeWord8Buf oraw ow     bom0-                    writeWord8Buf oraw (ow+1) bom1-                    writeWord8Buf oraw (ow+2) bom2-                    writeWord8Buf oraw (ow+3) bom3-                    utf32_native_encode input output{ bufR = ow+4 }--utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer-utf32_decode seen_bom-  input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }-  output- = do-   mb <- readIORef seen_bom-   case mb of-     Just decode -> decode input output-     Nothing ->-       if iw - ir < 4 then return (InputUnderflow, input,output) else do-       c0 <- readWord8Buf iraw ir-       c1 <- readWord8Buf iraw (ir+1)-       c2 <- readWord8Buf iraw (ir+2)-       c3 <- readWord8Buf iraw (ir+3)-       case () of-        _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do-               writeIORef seen_bom (Just utf32be_decode)-               utf32be_decode input{ bufL= ir+4 } output-        _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do-               writeIORef seen_bom (Just utf32le_decode)-               utf32le_decode input{ bufL= ir+4 } output-          | otherwise -> do-               writeIORef seen_bom (Just utf32_native_decode)-               utf32_native_decode input output---bom0, bom1, bom2, bom3 :: Word8-bom0 = 0-bom1 = 0-bom2 = 0xfe-bom3 = 0xff---- choose UTF-32BE by default for UTF-32 output-utf32_native_decode :: DecodeBuffer-utf32_native_decode = utf32be_decode--utf32_native_encode :: EncodeBuffer-utf32_native_encode = utf32be_encode---- -------------------------------------------------------------------------------- UTF32LE and UTF32BE--utf32be :: TextEncoding-utf32be = mkUTF32be ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF32be :: CodingFailureMode -> TextEncoding-mkUTF32be cfm = TextEncoding { textEncodingName = "UTF-32BE",-                               mkTextDecoder = utf32be_DF cfm,-                               mkTextEncoder = utf32be_EF cfm }--utf32be_DF :: CodingFailureMode -> IO (TextDecoder ())-utf32be_DF cfm =-  return (BufferCodec {-             encode   = utf32be_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf32be_EF :: CodingFailureMode -> IO (TextEncoder ())-utf32be_EF cfm =-  return (BufferCodec {-             encode   = utf32be_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })---utf32le :: TextEncoding-utf32le = mkUTF32le ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF32le :: CodingFailureMode -> TextEncoding-mkUTF32le cfm = TextEncoding { textEncodingName = "UTF-32LE",-                               mkTextDecoder = utf32le_DF cfm,-                               mkTextEncoder = utf32le_EF cfm }--utf32le_DF :: CodingFailureMode -> IO (TextDecoder ())-utf32le_DF cfm =-  return (BufferCodec {-             encode   = utf32le_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf32le_EF :: CodingFailureMode -> IO (TextEncoder ())-utf32le_EF cfm =-  return (BufferCodec {-             encode   = utf32le_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })---utf32be_decode :: DecodeBuffer-utf32be_decode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-       loop !ir !ow-         | ow >= os    = done OutputUnderflow ir ow-         | iw - ir < 4 = done InputUnderflow  ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              c1 <- readWord8Buf iraw (ir+1)-              c2 <- readWord8Buf iraw (ir+2)-              c3 <- readWord8Buf iraw (ir+3)-              let x1 = chr4 c0 c1 c2 c3-              if not (validate x1) then invalid else do-              ow' <- writeCharBuf oraw ow x1-              loop (ir+4) ow'-         where-           invalid = done InvalidSequence ir ow--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-    in-    loop ir0 ow0--utf32le_decode :: DecodeBuffer-utf32le_decode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-       loop !ir !ow-         | ow >= os    = done OutputUnderflow ir ow-         | iw - ir < 4 = done InputUnderflow  ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              c1 <- readWord8Buf iraw (ir+1)-              c2 <- readWord8Buf iraw (ir+2)-              c3 <- readWord8Buf iraw (ir+3)-              let x1 = chr4 c3 c2 c1 c0-              if not (validate x1) then invalid else do-              ow' <- writeCharBuf oraw ow x1-              loop (ir+4) ow'-         where-           invalid = done InvalidSequence ir ow--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-    in-    loop ir0 ow0--utf32be_encode :: EncodeBuffer-utf32be_encode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ir >= iw    = done InputUnderflow  ir ow-        | os - ow < 4 = done OutputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           if isSurrogate c then done InvalidSequence ir ow else do-             let (c0,c1,c2,c3) = ord4 c-             writeWord8Buf oraw ow     c0-             writeWord8Buf oraw (ow+1) c1-             writeWord8Buf oraw (ow+2) c2-             writeWord8Buf oraw (ow+3) c3-             loop ir' (ow+4)-    in-    loop ir0 ow0--utf32le_encode :: EncodeBuffer-utf32le_encode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ir >= iw    = done InputUnderflow  ir ow-        | os - ow < 4 = done OutputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           if isSurrogate c then done InvalidSequence ir ow else do-             let (c0,c1,c2,c3) = ord4 c-             writeWord8Buf oraw ow     c3-             writeWord8Buf oraw (ow+1) c2-             writeWord8Buf oraw (ow+2) c1-             writeWord8Buf oraw (ow+3) c0-             loop ir' (ow+4)-    in-    loop ir0 ow0--chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char-chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =-    C# (chr# (z1# +# z2# +# z3# +# z4#))-    where-      !y1# = word2Int# (word8ToWord# x1#)-      !y2# = word2Int# (word8ToWord# x2#)-      !y3# = word2Int# (word8ToWord# x3#)-      !y4# = word2Int# (word8ToWord# x4#)-      !z1# = uncheckedIShiftL# y1# 24#-      !z2# = uncheckedIShiftL# y2# 16#-      !z3# = uncheckedIShiftL# y3# 8#-      !z4# = y4#-{-# INLINE chr4 #-}--ord4 :: Char -> (Word8,Word8,Word8,Word8)-ord4 c = (fromIntegral (x `shiftR` 24),-          fromIntegral (x `shiftR` 16),-          fromIntegral (x `shiftR` 8),-          fromIntegral x)-  where-    x = ord c-{-# INLINE ord4 #-}---validate    :: Char -> Bool-validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)-   where x1 = ord c-{-# INLINE validate #-}
− GHC/IO/Encoding/UTF8.hs 
@@ -1,361 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , BangPatterns-           , NondecreasingIndentation-           , MagicHash-  #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Encoding.UTF8--- Copyright   :  (c) The University of Glasgow, 2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ UTF-8 Codec for the IO library------ Portions Copyright   : (c) Tom Harper 2008-2009,---                        (c) Bryan O'Sullivan 2009,---                        (c) Duncan Coutts 2009-----------------------------------------------------------------------------------module GHC.IO.Encoding.UTF8 (-  utf8, mkUTF8,-  utf8_bom, mkUTF8_bom-  ) where--import GHC.Base-import GHC.Real-import GHC.Num-import GHC.IORef--- import GHC.IO-import GHC.IO.Buffer-import GHC.IO.Encoding.Failure-import GHC.IO.Encoding.Types-import GHC.Word-import Data.Bits--utf8 :: TextEncoding-utf8 = mkUTF8 ErrorOnCodingFailure---- | @since 4.4.0.0-mkUTF8 :: CodingFailureMode -> TextEncoding-mkUTF8 cfm = TextEncoding { textEncodingName = "UTF-8",-                            mkTextDecoder = utf8_DF cfm,-                            mkTextEncoder = utf8_EF cfm }---utf8_DF :: CodingFailureMode -> IO (TextDecoder ())-utf8_DF cfm =-  return (BufferCodec {-             encode   = utf8_decode,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf8_EF :: CodingFailureMode -> IO (TextEncoder ())-utf8_EF cfm =-  return (BufferCodec {-             encode   = utf8_encode,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = return (),-             setState = const $ return ()-          })--utf8_bom :: TextEncoding-utf8_bom = mkUTF8_bom ErrorOnCodingFailure--mkUTF8_bom :: CodingFailureMode -> TextEncoding-mkUTF8_bom cfm = TextEncoding { textEncodingName = "UTF-8BOM",-                                mkTextDecoder = utf8_bom_DF cfm,-                                mkTextEncoder = utf8_bom_EF cfm }--utf8_bom_DF :: CodingFailureMode -> IO (TextDecoder Bool)-utf8_bom_DF cfm = do-   ref <- newIORef True-   return (BufferCodec {-             encode   = utf8_bom_decode ref,-             recover  = recoverDecode cfm,-             close    = return (),-             getState = readIORef ref,-             setState = writeIORef ref-          })--utf8_bom_EF :: CodingFailureMode -> IO (TextEncoder Bool)-utf8_bom_EF cfm = do-   ref <- newIORef True-   return (BufferCodec {-             encode   = utf8_bom_encode ref,-             recover  = recoverEncode cfm,-             close    = return (),-             getState = readIORef ref,-             setState = writeIORef ref-          })--utf8_bom_decode :: IORef Bool -> DecodeBuffer-utf8_bom_decode ref-  input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw,  bufSize=_  }-  output- = do-   first <- readIORef ref-   if not first-      then utf8_decode input output-      else do-       let no_bom = do writeIORef ref False; utf8_decode input output-       if iw - ir < 1 then return (InputUnderflow,input,output) else do-       c0 <- readWord8Buf iraw ir-       if (c0 /= bom0) then no_bom else do-       if iw - ir < 2 then return (InputUnderflow,input,output) else do-       c1 <- readWord8Buf iraw (ir+1)-       if (c1 /= bom1) then no_bom else do-       if iw - ir < 3 then return (InputUnderflow,input,output) else do-       c2 <- readWord8Buf iraw (ir+2)-       if (c2 /= bom2) then no_bom else do-       -- found a BOM, ignore it and carry on-       writeIORef ref False-       utf8_decode input{ bufL = ir + 3 } output--utf8_bom_encode :: IORef Bool -> EncodeBuffer-utf8_bom_encode ref input-  output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os }- = do-  b <- readIORef ref-  if not b then utf8_encode input output-           else if os - ow < 3-                  then return (OutputUnderflow,input,output)-                  else do-                    writeIORef ref False-                    writeWord8Buf oraw ow     bom0-                    writeWord8Buf oraw (ow+1) bom1-                    writeWord8Buf oraw (ow+2) bom2-                    utf8_encode input output{ bufR = ow+3 }--bom0, bom1, bom2 :: Word8-bom0 = 0xef-bom1 = 0xbb-bom2 = 0xbf--utf8_decode :: DecodeBuffer-utf8_decode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-       loop !ir !ow-         | ow >= os = done OutputUnderflow ir ow-         | ir >= iw = done InputUnderflow ir ow-         | otherwise = do-              c0 <- readWord8Buf iraw ir-              case c0 of-                _ | c0 <= 0x7f -> do-                           ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0))-                           loop (ir+1) ow'-                  | c0 >= 0xc0 && c0 <= 0xc1 -> invalid -- Overlong forms-                  | c0 >= 0xc2 && c0 <= 0xdf ->-                           if iw - ir < 2 then done InputUnderflow ir ow else do-                           c1 <- readWord8Buf iraw (ir+1)-                           if (c1 < 0x80 || c1 >= 0xc0) then invalid else do-                           ow' <- writeCharBuf oraw ow (chr2 c0 c1)-                           loop (ir+2) ow'-                  | c0 >= 0xe0 && c0 <= 0xef ->-                      case iw - ir of-                        1 -> done InputUnderflow ir ow-                        2 -> do -- check for an error even when we don't have-                                -- the full sequence yet (#3341)-                           c1 <- readWord8Buf iraw (ir+1)-                           if not (validate3 c0 c1 0x80)-                              then invalid else done InputUnderflow ir ow-                        _ -> do-                           c1 <- readWord8Buf iraw (ir+1)-                           c2 <- readWord8Buf iraw (ir+2)-                           if not (validate3 c0 c1 c2) then invalid else do-                           ow' <- writeCharBuf oraw ow (chr3 c0 c1 c2)-                           loop (ir+3) ow'-                  | c0 >= 0xf0 ->-                      case iw - ir of-                        1 -> done InputUnderflow ir ow-                        2 -> do -- check for an error even when we don't have-                                -- the full sequence yet (#3341)-                           c1 <- readWord8Buf iraw (ir+1)-                           if not (validate4 c0 c1 0x80 0x80)-                              then invalid else done InputUnderflow ir ow-                        3 -> do-                           c1 <- readWord8Buf iraw (ir+1)-                           c2 <- readWord8Buf iraw (ir+2)-                           if not (validate4 c0 c1 c2 0x80)-                              then invalid else done InputUnderflow ir ow-                        _ -> do-                           c1 <- readWord8Buf iraw (ir+1)-                           c2 <- readWord8Buf iraw (ir+2)-                           c3 <- readWord8Buf iraw (ir+3)-                           if not (validate4 c0 c1 c2 c3) then invalid else do-                           ow' <- writeCharBuf oraw ow (chr4 c0 c1 c2 c3)-                           loop (ir+4) ow'-                  | otherwise ->-                           invalid-         where-           invalid = done InvalidSequence ir ow--       -- lambda-lifted, to avoid thunks being built in the inner-loop:-       done why !ir !ow = return (why,-                                  if ir == iw then input{ bufL=0, bufR=0 }-                                              else input{ bufL=ir },-                                  output{ bufR=ow })-   in-   loop ir0 ow0--utf8_encode :: EncodeBuffer-utf8_encode-  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }-  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }- = let-      done why !ir !ow = return (why,-                                 if ir == iw then input{ bufL=0, bufR=0 }-                                             else input{ bufL=ir },-                                 output{ bufR=ow })-      loop !ir !ow-        | ow >= os = done OutputUnderflow ir ow-        | ir >= iw = done InputUnderflow ir ow-        | otherwise = do-           (c,ir') <- readCharBuf iraw ir-           case ord c of-             x | x <= 0x7F   -> do-                    writeWord8Buf oraw ow (fromIntegral x)-                    loop ir' (ow+1)-               | x <= 0x07FF ->-                    if os - ow < 2 then done OutputUnderflow ir ow else do-                    let (c1,c2) = ord2 c-                    writeWord8Buf oraw ow     c1-                    writeWord8Buf oraw (ow+1) c2-                    loop ir' (ow+2)-               | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow else do-                    if os - ow < 3 then done OutputUnderflow ir ow else do-                    let (c1,c2,c3) = ord3 c-                    writeWord8Buf oraw ow     c1-                    writeWord8Buf oraw (ow+1) c2-                    writeWord8Buf oraw (ow+2) c3-                    loop ir' (ow+3)-               | otherwise -> do-                    if os - ow < 4 then done OutputUnderflow ir ow else do-                    let (c1,c2,c3,c4) = ord4 c-                    writeWord8Buf oraw ow     c1-                    writeWord8Buf oraw (ow+1) c2-                    writeWord8Buf oraw (ow+2) c3-                    writeWord8Buf oraw (ow+3) c4-                    loop ir' (ow+4)-   in-   loop ir0 ow0---- -------------------------------------------------------------------------------- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8--ord2   :: Char -> (Word8,Word8)-ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2)-    where-      n  = ord c-      x1 = fromIntegral $ (n `shiftR` 6) + 0xC0-      x2 = fromIntegral $ (n .&. 0x3F)   + 0x80--ord3   :: Char -> (Word8,Word8,Word8)-ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3)-    where-      n  = ord c-      x1 = fromIntegral $ (n `shiftR` 12) + 0xE0-      x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80-      x3 = fromIntegral $ (n .&. 0x3F) + 0x80--ord4   :: Char -> (Word8,Word8,Word8,Word8)-ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4)-    where-      n  = ord c-      x1 = fromIntegral $ (n `shiftR` 18) + 0xF0-      x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80-      x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80-      x4 = fromIntegral $ (n .&. 0x3F) + 0x80--chr2       :: Word8 -> Word8 -> Char-chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))-    where-      !y1# = word2Int# (word8ToWord# x1#)-      !y2# = word2Int# (word8ToWord# x2#)-      !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#-      !z2# = y2# -# 0x80#-{-# INLINE chr2 #-}--chr3          :: Word8 -> Word8 -> Word8 -> Char-chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))-    where-      !y1# = word2Int# (word8ToWord# x1#)-      !y2# = word2Int# (word8ToWord# x2#)-      !y3# = word2Int# (word8ToWord# x3#)-      !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#-      !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#-      !z3# = y3# -# 0x80#-{-# INLINE chr3 #-}--chr4             :: Word8 -> Word8 -> Word8 -> Word8 -> Char-chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =-    C# (chr# (z1# +# z2# +# z3# +# z4#))-    where-      !y1# = word2Int# (word8ToWord# x1#)-      !y2# = word2Int# (word8ToWord# x2#)-      !y3# = word2Int# (word8ToWord# x3#)-      !y4# = word2Int# (word8ToWord# x4#)-      !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#-      !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#-      !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#-      !z4# = y4# -# 0x80#-{-# INLINE chr4 #-}--between :: Word8                -- ^ byte to check-        -> Word8                -- ^ lower bound-        -> Word8                -- ^ upper bound-        -> Bool-between x y z = x >= y && x <= z-{-# INLINE between #-}--validate3          :: Word8 -> Word8 -> Word8 -> Bool-{-# INLINE validate3 #-}-validate3 x1 x2 x3 = validate3_1 ||-                     validate3_2 ||-                     validate3_3 ||-                     validate3_4-  where-    validate3_1 = (x1 == 0xE0) &&-                  between x2 0xA0 0xBF &&-                  between x3 0x80 0xBF-    validate3_2 = between x1 0xE1 0xEC &&-                  between x2 0x80 0xBF &&-                  between x3 0x80 0xBF-    validate3_3 = x1 == 0xED &&-                  between x2 0x80 0x9F &&-                  between x3 0x80 0xBF-    validate3_4 = between x1 0xEE 0xEF &&-                  between x2 0x80 0xBF &&-                  between x3 0x80 0xBF--validate4             :: Word8 -> Word8 -> Word8 -> Word8 -> Bool-{-# INLINE validate4 #-}-validate4 x1 x2 x3 x4 = validate4_1 ||-                        validate4_2 ||-                        validate4_3-  where-    validate4_1 = x1 == 0xF0 &&-                  between x2 0x90 0xBF &&-                  between x3 0x80 0xBF &&-                  between x4 0x80 0xBF-    validate4_2 = between x1 0xF1 0xF3 &&-                  between x2 0x80 0xBF &&-                  between x3 0x80 0xBF &&-                  between x4 0x80 0xBF-    validate4_3 = x1 == 0xF4 &&-                  between x2 0x80 0x8F &&-                  between x3 0x80 0xBF &&-                  between x4 0x80 0xBF
− GHC/IO/Exception.hs 
@@ -1,474 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash,-             ExistentialQuantification, ImplicitParams #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Exception--- Copyright   :  (c) The University of Glasgow, 2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ IO-related Exception types and functions-----------------------------------------------------------------------------------module GHC.IO.Exception (-  BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,-  BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,-  Deadlock(..),-  AllocationLimitExceeded(..), allocationLimitExceeded,-  AssertionFailed(..),-  CompactionFailed(..),-  cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,--  SomeAsyncException(..),-  asyncExceptionToException, asyncExceptionFromException,-  AsyncException(..), stackOverflow, heapOverflow,--  ArrayException(..),-  ExitCode(..),-  FixIOException (..),--  ioException,-  ioError,-  IOError,-  IOException(..),-  IOErrorType(..),-  userError,-  assertError,-  unsupportedOperation,-  untangle,- ) 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 ( cast )---- --------------------------------------------------------------------------- Exception datatypes and operations---- |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---- | @since 4.1.0.0-instance Exception BlockedIndefinitelyOnMVar---- | @since 4.1.0.0-instance Show BlockedIndefinitelyOnMVar where-    showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely in an MVar operation"--blockedIndefinitelyOnMVar :: SomeException -- for the RTS-blockedIndefinitelyOnMVar = toException BlockedIndefinitelyOnMVar----------- |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---- | @since 4.1.0.0-instance Exception BlockedIndefinitelyOnSTM---- | @since 4.1.0.0-instance Show BlockedIndefinitelyOnSTM where-    showsPrec _ BlockedIndefinitelyOnSTM = showString "thread blocked indefinitely in an STM transaction"--blockedIndefinitelyOnSTM :: SomeException -- for the RTS-blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM----------- |There are no runnable threads, so the program is deadlocked.--- The @Deadlock@ exception is raised in the main thread only.-data Deadlock = Deadlock---- | @since 4.1.0.0-instance Exception Deadlock---- | @since 4.1.0.0-instance Show Deadlock where-    showsPrec _ Deadlock = showString "<<deadlock>>"----------- |This thread has exceeded its allocation limit.  See--- 'System.Mem.setAllocationCounter' and--- 'System.Mem.enableAllocationLimit'.------ @since 4.8.0.0-data AllocationLimitExceeded = AllocationLimitExceeded---- | @since 4.8.0.0-instance Exception AllocationLimitExceeded where-  toException = asyncExceptionToException-  fromException = asyncExceptionFromException---- | @since 4.7.1.0-instance Show AllocationLimitExceeded where-    showsPrec _ AllocationLimitExceeded =-      showString "allocation limit exceeded"--allocationLimitExceeded :: SomeException -- for the RTS-allocationLimitExceeded = toException AllocationLimitExceeded----------- | Compaction found an object that cannot be compacted.  Functions--- cannot be compacted, nor can mutable objects or pinned objects.--- See 'GHC.Compact.compact'.------ @since 4.10.0.0-newtype CompactionFailed = CompactionFailed String---- | @since 4.10.0.0-instance Exception CompactionFailed where---- | @since 4.10.0.0-instance Show CompactionFailed where-    showsPrec _ (CompactionFailed why) =-      showString ("compaction failed: " ++ why)--cannotCompactFunction :: SomeException -- for the RTS-cannotCompactFunction =-  toException (CompactionFailed "cannot compact functions")--cannotCompactPinned :: SomeException -- for the RTS-cannotCompactPinned =-  toException (CompactionFailed "cannot compact pinned objects")--cannotCompactMutable :: SomeException -- for the RTS-cannotCompactMutable =-  toException (CompactionFailed "cannot compact mutable objects")----------- |'assert' was applied to 'False'.-newtype AssertionFailed = AssertionFailed String---- | @since 4.1.0.0-instance Exception AssertionFailed---- | @since 4.1.0.0-instance Show AssertionFailed where-    showsPrec _ (AssertionFailed err) = showString err----------- |Superclass for asynchronous exceptions.------ @since 4.7.0.0-data SomeAsyncException = forall e . Exception e => SomeAsyncException e---- | @since 4.7.0.0-instance Show SomeAsyncException where-    showsPrec p (SomeAsyncException e) = showsPrec p e---- | @since 4.7.0.0-instance Exception SomeAsyncException---- |@since 4.7.0.0-asyncExceptionToException :: Exception e => e -> SomeException-asyncExceptionToException = toException . SomeAsyncException---- |@since 4.7.0.0-asyncExceptionFromException :: Exception e => SomeException -> Maybe e-asyncExceptionFromException x = do-    SomeAsyncException a <- fromException x-    cast a----- |Asynchronous exceptions.-data AsyncException-  = StackOverflow-        -- ^The current thread\'s stack exceeded its limit.-        -- Since an exception has been raised, the thread\'s stack-        -- will certainly be below its limit again, but the-        -- programmer should take remedial action-        -- immediately.-  | HeapOverflow-        -- ^The program\'s heap is reaching its limit, and-        -- the program should take action to reduce the amount of-        -- live data it has. Notes:-        ---        --   * It is undefined which thread receives this exception.-        --     GHC currently throws this to the same thread that-        --     receives 'UserInterrupt', but this may change in the-        --     future.-        ---        --   * The GHC RTS currently can only recover from heap overflow-        --     if it detects that an explicit memory limit (set via RTS flags).-        --     has been exceeded.  Currently, failure to allocate memory from-        --     the operating system results in immediate termination of the-        --     program.-  | ThreadKilled-        -- ^This exception is raised by another thread-        -- calling 'Control.Concurrent.killThread', or by the system-        -- if it needs to terminate the thread for some-        -- reason.-  | UserInterrupt-        -- ^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  -- ^ @since 4.2.0.0-           , Ord -- ^ @since 4.2.0.0-           )---- | @since 4.7.0.0-instance Exception AsyncException where-  toException = asyncExceptionToException-  fromException = asyncExceptionFromException---- | Exceptions generated by array operations-data ArrayException-  = IndexOutOfBounds    String-        -- ^An attempt was made to index an array outside-        -- its declared bounds.-  | UndefinedElement    String-        -- ^An attempt was made to evaluate an element of an-        -- array that had not been initialized.-  deriving ( Eq  -- ^ @since 4.2.0.0-           , Ord -- ^ @since 4.2.0.0-           )---- | @since 4.1.0.0-instance Exception ArrayException---- for the RTS-stackOverflow, heapOverflow :: SomeException-stackOverflow = toException StackOverflow-heapOverflow  = toException HeapOverflow---- | @since 4.1.0.0-instance Show AsyncException where-  showsPrec _ StackOverflow   = showString "stack overflow"-  showsPrec _ HeapOverflow    = showString "heap overflow"-  showsPrec _ ThreadKilled    = showString "thread killed"-  showsPrec _ UserInterrupt   = showString "user interrupt"---- | @since 4.1.0.0-instance Show ArrayException where-  showsPrec _ (IndexOutOfBounds s)-        = showString "array index out of range"-        . (if not (null s) then showString ": " . showString s-                           else id)-  showsPrec _ (UndefinedElement s)-        = showString "undefined array element"-        . (if not (null s) then showString ": " . showString s-                           else id)---- | The exception thrown when an infinite cycle is detected in--- 'System.IO.fixIO'.------ @since 4.11.0.0-data FixIOException = FixIOException---- | @since 4.11.0.0-instance Exception FixIOException---- | @since 4.11.0.0-instance Show FixIOException where-  showsPrec _ FixIOException = showString "cyclic evaluation in fixIO"---- -------------------------------------------------------------------------------- The ExitCode type---- We need it here because it is used in ExitException in the--- Exception datatype (above).---- | Defines the exit codes that a program can return.-data ExitCode-  = ExitSuccess -- ^ indicates successful termination;-  | ExitFailure Int-                -- ^ indicates program failure with an exit code.-                -- 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, Generic)---- | @since 4.1.0.0-instance Exception ExitCode--ioException     :: IOException -> IO a-ioException err = throwIO err---- | Raise an 'IOError' in the 'IO' monad.-ioError         :: IOError -> IO a-ioError         =  ioException---- ------------------------------------------------------------------------------ IOError type---- | 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 Haskell 2010, this is an opaque type.-type IOError = IOException---- |Exceptions that occur in the @IO@ monad.--- An @IOException@ records a more specific error type, a descriptive--- string and maybe the handle that was used when the error was--- flagged.-data IOException- = IOError {-     ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging-                                     -- the error.-     ioe_type     :: IOErrorType,    -- what it was.-     ioe_location :: String,         -- location.-     ioe_description :: String,      -- error type specific information.-     ioe_errno    :: Maybe CInt,     -- errno leading to this error, if any.-     ioe_filename :: Maybe FilePath  -- filename the error is related to.-   }---- | @since 4.1.0.0-instance Exception IOException---- | @since 4.1.0.0-instance Eq IOException where-  (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) =-    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2---- | An abstract type that contains a value for each variant of 'IOError'.-data IOErrorType-  -- Haskell 2010:-  = AlreadyExists-  | NoSuchThing-  | ResourceBusy-  | ResourceExhausted-  | EOF-  | IllegalOperation-  | PermissionDenied-  | UserError-  -- GHC only:-  | UnsatisfiedConstraints-  | SystemError-  | ProtocolError-  | OtherError-  | InvalidArgument-  | InappropriateType-  | HardwareFault-  | UnsupportedOperation-  | TimeExpired-  | ResourceVanished-  | Interrupted---- | @since 4.1.0.0-instance Eq IOErrorType where-   x == y = isTrue# (getTag x ==# getTag y)---- | @since 4.1.0.0-instance Show IOErrorType where-  showsPrec _ e =-    showString $-    case e of-      AlreadyExists     -> "already exists"-      NoSuchThing       -> "does not exist"-      ResourceBusy      -> "resource busy"-      ResourceExhausted -> "resource exhausted"-      EOF               -> "end of file"-      IllegalOperation  -> "illegal operation"-      PermissionDenied  -> "permission denied"-      UserError         -> "user error"-      HardwareFault     -> "hardware fault"-      InappropriateType -> "inappropriate type"-      Interrupted       -> "interrupted"-      InvalidArgument   -> "invalid argument"-      OtherError        -> "failed"-      ProtocolError     -> "protocol error"-      ResourceVanished  -> "resource vanished"-      SystemError       -> "system error"-      TimeExpired       -> "timeout"-      UnsatisfiedConstraints -> "unsatisfied constraints" -- ultra-precise!-      UnsupportedOperation -> "unsupported operation"---- | Construct an 'IOError' value with a string describing the error.--- The 'fail' method of the 'IO' instance of the 'Monad' class raises a--- 'userError', thus:------ > instance Monad IO where--- >   ...--- >   fail s = ioError (userError s)----userError       :: String  -> IOError-userError str   =  IOError Nothing UserError "" str Nothing Nothing---- ------------------------------------------------------------------------------ Showing IOErrors---- | @since 4.1.0.0-instance Show IOException where-    showsPrec p (IOError hdl iot loc s _ fn) =-      (case fn of-         Nothing -> case hdl of-                        Nothing -> id-                        Just h  -> showsPrec p h . showString ": "-         Just name -> showString name . showString ": ") .-      (case loc of-         "" -> id-         _  -> showString loc . showString ": ") .-      showsPrec p iot .-      (case s of-         "" -> id-         _  -> showString " (" . showString s . showString ")")---- Note the use of "lazy". This means that---     assert False (throw e)--- will throw the assertion failure rather than e. See trac #5561.-assertError :: (?callStack :: CallStack) => Bool -> a -> a-assertError predicate v-  | predicate = lazy v-  | 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 =-   (IOError Nothing UnsupportedOperation ""-        "Operation is not supported" Nothing Nothing)--{--(untangle coded message) expects "coded" to be of the form-        "location|details"-It prints-        location message details--}-untangle :: Addr# -> String -> String-untangle coded message-  =  location-  ++ ": "-  ++ message-  ++ details-  ++ "\n"-  where-    coded_str = unpackCStringUtf8# coded--    (location, details)-      = case (span not_bar coded_str) of { (loc, rest) ->-        case rest of-          ('|':det) -> (loc, ' ' : det)-          _         -> (loc, "")-        }-    not_bar c = c /= '|'-
− GHC/IO/Exception.hs-boot 
@@ -1,15 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO.Exception where--import GHC.Base-import GHC.Exception--data IOException-instance Exception IOException--type IOError = IOException-userError :: String  -> IOError-unsupportedOperation :: IOError-
− GHC/IO/FD.hs 
@@ -1,792 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , BangPatterns-           , RankNTypes-  #-}-{-# OPTIONS_GHC -Wno-identities #-}--- Whether there are identities depends on the platform-{-# OPTIONS_HADDOCK not-home #-}--------------------------------------------------------------------------------- |--- Module      :  GHC.IO.FD--- Copyright   :  (c) The University of Glasgow, 1994-2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Raw read/write operations on file descriptors-----------------------------------------------------------------------------------module GHC.IO.FD (-        FD(..),-        openFileWith, openFile, mkFD, release,-        setNonBlockingMode,-        readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr,-        stdin, stdout, stderr-    ) where--import GHC.Base-import GHC.Num-import GHC.Real-import GHC.Show-import GHC.Enum--import GHC.IO-import GHC.IO.IOMode-import GHC.IO.Buffer-import GHC.IO.BufferedIO-import qualified GHC.IO.Device-import GHC.IO.Device (SeekMode(..), IODeviceType(..))-import GHC.Conc.IO-import GHC.IO.Exception-#if defined(mingw32_HOST_OS)-import GHC.Windows-import Data.Bool-import GHC.IO.SubSystem ((<!>))-#endif--import Foreign-import Foreign.C-import qualified System.Posix.Internals-import System.Posix.Internals hiding (FD, setEcho, getEcho)-import System.Posix.Types--#if defined(mingw32_HOST_OS)-# if defined(i386_HOST_ARCH)-#  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-#  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif-#endif--c_DEBUG_DUMP :: Bool-c_DEBUG_DUMP = False---- Darwin limits the length of writes to 2GB. See #17414.--- Moreover, Linux will only transfer up to 0x7ffff000 and interpreting the--- result of write/read is tricky above 2GB due to its signed type. For--- simplicity we therefore clamp on all platforms.-clampWriteSize, clampReadSize :: Int -> Int-clampWriteSize = min 0x7ffff000-clampReadSize  = min 0x7ffff000---- -------------------------------------------------------------------------------- The file-descriptor IO device--data FD = FD {-  fdFD :: {-# UNPACK #-} !CInt,-#if defined(mingw32_HOST_OS)-  -- On Windows, a socket file descriptor needs to be read and written-  -- using different functions (send/recv).-  fdIsSocket_ :: {-# UNPACK #-} !Int-#else-  -- On Unix we need to know whether this FD has O_NONBLOCK set.-  -- If it has, then we can use more efficient routines to read/write to it.-  -- It is always safe for this to be off.-  fdIsNonBlocking :: {-# UNPACK #-} !Int-#endif- }--#if defined(mingw32_HOST_OS)-fdIsSocket :: FD -> Bool-fdIsSocket fd = fdIsSocket_ fd /= 0-#endif---- | @since 4.1.0.0-instance Show FD where-  show fd = show (fdFD fd)--{-# INLINE ifSupported #-}-ifSupported :: String -> a -> a-#if defined(mingw32_HOST_OS)-ifSupported s a = a <!> (error $ "FD:" ++ s ++ " not supported")-#else-ifSupported _ = id-#endif---- | @since 4.1.0.0-instance GHC.IO.Device.RawIO FD where-  read             = ifSupported "fdRead" fdRead-  readNonBlocking  = ifSupported "fdReadNonBlocking" fdReadNonBlocking-  write            = ifSupported "fdWrite" fdWrite-  writeNonBlocking = ifSupported "fdWriteNonBlocking" fdWriteNonBlocking---- | @since 4.1.0.0-instance GHC.IO.Device.IODevice FD where-  ready         = ifSupported "ready" ready-  close         = ifSupported "close" close-  isTerminal    = ifSupported "isTerm" isTerminal-  isSeekable    = ifSupported "isSeek" isSeekable-  seek          = ifSupported "seek" seek-  tell          = ifSupported "tell" tell-  getSize       = ifSupported "getSize" getSize-  setSize       = ifSupported "setSize" setSize-  setEcho       = ifSupported "setEcho" setEcho-  getEcho       = ifSupported "getEcho" getEcho-  setRaw        = ifSupported "setRaw" setRaw-  devType       = ifSupported "devType" devType-  dup           = ifSupported "dup" dup-  dup2          = ifSupported "dup2" dup2---- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is--- taken from the value of BUFSIZ on the current platform.  This value--- varies too much though: it is 512 on Windows, 1024 on OS X and 8192--- on Linux.  So let's just use a decent size on every platform:-dEFAULT_FD_BUFFER_SIZE :: Int-dEFAULT_FD_BUFFER_SIZE = 8192---- | @since 4.1.0.0-instance BufferedIO FD where-  newBuffer _dev state = ifSupported "newBuf" $ newByteBuffer dEFAULT_FD_BUFFER_SIZE state-  fillReadBuffer    fd buf = ifSupported "readBuf" $ readBuf' fd buf-  fillReadBuffer0   fd buf = ifSupported "readBufNonBlock" $ readBufNonBlocking fd buf-  flushWriteBuffer  fd buf = ifSupported "writeBuf" $ writeBuf' fd buf-  flushWriteBuffer0 fd buf = ifSupported "writeBufNonBlock" $ writeBufNonBlocking fd buf--readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)-readBuf' fd buf = do-  when c_DEBUG_DUMP $-      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")-  (r,buf') <- readBuf fd buf-  when c_DEBUG_DUMP $-      puts ("after: " ++ summaryBuffer buf' ++ "\n")-  return (r,buf')--writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)-writeBuf' fd buf = do-  when c_DEBUG_DUMP $-      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")-  writeBuf fd buf---- -------------------------------------------------------------------------------- opening files---- | A wrapper for 'System.Posix.Internals.c_interruptible_open' that takes--- two actions, @act1@ and @act2@, to perform after opening the file.------ @act1@ is passed a file descriptor for the newly opened file. If--- an exception occurs in @act1@, then the file will be closed.--- @act1@ /must not/ close the file itself. If it does so and then--- receives an exception, then the exception handler will attempt to--- close it again, which is impermissable.------ @act2@ is performed with asynchronous exceptions masked. It is passed a--- function to restore the masking state and the result of @act1@.--- It /must not/ throw an exception (or deliver one via an interruptible--- operation) without first closing the file or arranging for it to be--- closed. @act2@ /may/ close the file, but is not required to do so.--- If @act2@ leaves the file open, then the file will remain open on--- return from `c_interruptible_open_with`.------ Code calling `c_interruptible_open_with` that wishes to install a finalizer--- to close the file should do so in @act2@. Doing so in @act1@ could--- potentially close the file in the finalizer first and then in the--- exception handler.--c_interruptible_open_with-  :: System.Posix.Internals.CFilePath  -- ^ The file to open-  -> CInt -- ^ The flags to pass to open-  -> CMode -- ^ The permission mode to use for file creation-  -> (CInt -> IO r) -- ^ @act1@: An action to perform on the file descriptor-                    -- with the masking state restored and an exception-                    -- handler that closes the file on exception.-  -> ((forall x. IO x -> IO x) -> r -> IO s)-                    -- ^ @act2@: An action to perform with async exceptions-                    -- masked and no exception handler.-  -> IO s-c_interruptible_open_with path oflags mode act1 act2 =-  mask $ \restore -> do-    fd <- throwErrnoIfMinus1Retry "openFile" $-             c_interruptible_open path oflags mode-    r <- restore (act1 fd) `onException` c_close fd-    act2 restore r---- | Open a file and make an 'FD' for it. Truncates the file to zero size when--- the `IOMode` is `WriteMode`.------ `openFileWith` takes two actions, @act1@ and @act2@, to perform after--- opening the file.------ @act1@ is passed a file descriptor and I/O device type for the newly opened--- file. If an exception occurs in @act1@, then the file will be closed.--- @act1@ /must not/ close the file itself. If it does so and then receives an--- exception, then the exception handler will attempt to close it again, which--- is impermissable.------ @act2@ is performed with asynchronous exceptions masked. It is passed a--- function to restore the masking state and the result of @act1@.  It /must--- not/ throw an exception (or deliver one via an interruptible operation)--- without first closing the file or arranging for it to be closed. @act2@--- /may/ close the file, but is not required to do so.  If @act2@ leaves the--- file open, then the file will remain open on return from `openFileWith`.------ Code calling `openFileWith` that wishes to install a finalizer to close--- the file should do so in @act2@. Doing so in @act1@ could potentially close--- the file in the finalizer first and then in the exception handler. See--- 'GHC.IO.Handle.FD.openFile'' for an example of this use. Regardless, the--- caller is responsible for ensuring that the file is eventually closed,--- perhaps using 'Control.Exception.bracket'.--openFileWith-  :: FilePath -- ^ file to open-  -> IOMode   -- ^ mode in which to open the file-  -> Bool     -- ^ open the file in non-blocking mode?-  -> (FD -> IODeviceType -> IO r) -- ^ @act1@: An action to perform-                    -- on the file descriptor with the masking state-                    -- restored and an exception handler that closes-                    -- the file on exception.-  -> ((forall x. IO x -> IO x) -> r -> IO s)-                    -- ^ @act2@: An action to perform with async exceptions-                    -- masked and no exception handler.-  -> IO s-openFileWith filepath iomode non_blocking act1 act2 =-  withFilePath filepath $ \ f ->-    let-      oflags1 = case iomode of-                  ReadMode      -> read_flags-                  WriteMode     -> write_flags-                  ReadWriteMode -> rw_flags-                  AppendMode    -> append_flags--#if defined(mingw32_HOST_OS)-      binary_flags = o_BINARY-#else-      binary_flags = 0-#endif--      oflags2 = oflags1 .|. binary_flags--      oflags | non_blocking = oflags2 .|. nonblock_flags-             | otherwise    = oflags2-    in do-      -- We want to be sure all the arguments to c_interruptible_open_with-      -- are fully evaluated *before* it slips under a mask (assuming we're-      -- not already under a user-imposed mask).-      oflags' <- evaluate oflags-      -- NB. always use a safe open(), because we don't know whether open()-      -- will be fast or not.  It can be slow on NFS and FUSE filesystems,-      -- for example.-      c_interruptible_open_with f oflags' 0o666 ( \ fileno -> do-        (fD,fd_type) <- mkFD fileno iomode Nothing{-no stat-}-                                False{-not a socket-}-                                non_blocking-        -- we want to truncate() if this is an open in WriteMode, but only-        -- if the target is a RegularFile.  ftruncate() fails on special files-        -- like /dev/null.-        when (iomode == WriteMode && fd_type == RegularFile) $-          setSize fD 0-        act1 fD fd_type ) act2---- | Open a file and make an 'FD' for it.  Truncates the file to zero--- size when the `IOMode` is `WriteMode`. This function is difficult--- to use without potentially leaking the file descriptor on exception.--- In particular, it must be used with exceptions masked, which is a--- bit rude because the thread will be uninterruptible while the file--- path is being encoded. Use 'openFileWith' instead.-openFile-  :: FilePath -- ^ file to open-  -> IOMode   -- ^ mode in which to open the file-  -> Bool     -- ^ open the file in non-blocking mode?-  -> IO (FD,IODeviceType)-openFile filepath iomode non_blocking =-  openFileWith filepath iomode non_blocking-    (\ fd fd_type -> pure (fd, fd_type)) (\_ r -> pure r)--std_flags, output_flags, read_flags, write_flags, rw_flags,-    append_flags, nonblock_flags :: CInt-std_flags    = o_NOCTTY-output_flags = std_flags    .|. o_CREAT-read_flags   = std_flags    .|. o_RDONLY-write_flags  = output_flags .|. o_WRONLY-rw_flags     = output_flags .|. o_RDWR-append_flags = write_flags  .|. o_APPEND-nonblock_flags = o_NONBLOCK----- | Make a 'FD' from an existing file descriptor.  Fails if the FD--- refers to a directory.  If the FD refers to a file, `mkFD` locks--- the file according to the Haskell 2010 single writer/multiple reader--- locking semantics (this is why we need the `IOMode` argument too).-mkFD :: CInt-     -> IOMode-     -> Maybe (IODeviceType, CDev, CIno)-     -- the results of fdStat if we already know them, or we want-     -- to prevent fdToHandle_stat from doing its own stat.-     -- These are used for:-     --   - we fail if the FD refers to a directory-     --   - if the FD refers to a file, we lock it using (cdev,cino)-     -> Bool   -- ^ is a socket (on Windows)-     -> Bool   -- ^ is in non-blocking mode on Unix-     -> IO (FD,IODeviceType)--mkFD fd iomode mb_stat is_socket is_nonblock = do--    let _ = (is_socket, is_nonblock) -- warning suppression--    (fd_type,dev,ino) <--        case mb_stat of-          Nothing   -> fdStat fd-          Just stat -> return stat--    let write = case iomode of-                   ReadMode -> False-                   _ -> True--    case fd_type of-        Directory ->-           ioException (IOError Nothing InappropriateType "openFile"-                           "is a directory" Nothing Nothing)--        -- regular files need to be locked-        RegularFile -> do-           -- On Windows we need an additional call to get a unique device id-           -- and inode, since fstat just returns 0 for both.-           -- See also Note [RTS File locking]-           (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino-           r <- lockFile (fromIntegral fd) unique_dev unique_ino-                         (fromBool write)-           when (r == -1)  $-                ioException (IOError Nothing ResourceBusy "openFile"-                                   "file is locked" Nothing Nothing)--        _other_type -> return ()--#if defined(mingw32_HOST_OS)-    when (not is_socket) $ setmode fd True >> return ()-#endif--    return (FD{ fdFD = fd,-#if !defined(mingw32_HOST_OS)-                fdIsNonBlocking = fromEnum is_nonblock-#else-                fdIsSocket_ = fromEnum is_socket-#endif-              },-            fd_type)--getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)-#if !defined(mingw32_HOST_OS)-getUniqueFileInfo _ dev ino = return (fromIntegral dev, fromIntegral ino)-#else-getUniqueFileInfo fd _ _ = do-  with 0 $ \devptr -> do-    with 0 $ \inoptr -> do-      c_getUniqueFileInfo fd devptr inoptr-      liftM2 (,) (peek devptr) (peek inoptr)-#endif--#if defined(mingw32_HOST_OS)-foreign import ccall unsafe "__hscore_setmode"-  setmode :: CInt -> Bool -> IO CInt-#endif---- -------------------------------------------------------------------------------- Standard file descriptors--stdFD :: CInt -> FD-stdFD fd = FD { fdFD = fd,-#if defined(mingw32_HOST_OS)-                fdIsSocket_ = 0-#else-                fdIsNonBlocking = 0-   -- We don't set non-blocking mode on standard handles, because it may-   -- confuse other applications attached to the same TTY/pipe-   -- see Note [nonblock]-#endif-                }--stdin, stdout, stderr :: FD-stdin  = stdFD 0-stdout = stdFD 1-stderr = stdFD 2---- -------------------------------------------------------------------------------- Operations on file descriptors--close :: FD -> IO ()-close fd =-  do let closer realFd =-           throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $-#if defined(mingw32_HOST_OS)-           if fdIsSocket fd then-             c_closesocket (fromIntegral realFd)-           else-#endif-             c_close (fromIntegral realFd)--     -- release the lock *first*, because otherwise if we're preempted-     -- after closing but before releasing, the FD may have been reused.-     -- (#7646)-     release fd--     closeFdWith closer (fromIntegral (fdFD fd))--release :: FD -> IO ()-release fd = do _ <- unlockFile (fromIntegral $ fdFD fd)-                return ()--#if defined(mingw32_HOST_OS)-foreign import WINDOWS_CCONV unsafe "HsBase.h closesocket"-   c_closesocket :: CInt -> IO CInt-#endif--isSeekable :: FD -> IO Bool-isSeekable fd = do-  t <- devType fd-  return (t == RegularFile || t == RawDevice)--seek :: FD -> SeekMode -> Integer -> IO Integer-seek fd mode off = fromIntegral `fmap`-  (throwErrnoIfMinus1Retry "seek" $-     c_lseek (fdFD fd) (fromIntegral off) seektype)- where-    seektype :: CInt-    seektype = case mode of-                   AbsoluteSeek -> sEEK_SET-                   RelativeSeek -> sEEK_CUR-                   SeekFromEnd  -> sEEK_END--tell :: FD -> IO Integer-tell fd =- fromIntegral `fmap`-   (throwErrnoIfMinus1Retry "hGetPosn" $-      c_lseek (fdFD fd) 0 sEEK_CUR)--getSize :: FD -> IO Integer-getSize fd = fdFileSize (fdFD fd)--setSize :: FD -> Integer -> IO ()-setSize fd size =-  throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $-     c_ftruncate (fdFD fd) (fromIntegral size)--devType :: FD -> IO IODeviceType-devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty--dup :: FD -> IO FD-dup fd = do-  newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd)-  return fd{ fdFD = newfd }--dup2 :: FD -> FD -> IO FD-dup2 fd fdto = do-  -- Windows' dup2 does not return the new descriptor, unlike Unix-  throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $-    c_dup2 (fdFD fd) (fdFD fdto)-  return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD--setNonBlockingMode :: FD -> Bool -> IO FD-setNonBlockingMode fd set = do-  setNonBlockingFD (fdFD fd) set-#if defined(mingw32_HOST_OS)-  return fd-#else-  return fd{ fdIsNonBlocking = fromEnum set }-#endif--ready :: FD -> Bool -> Int -> IO Bool-ready fd write msecs = do-  r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $-          fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)-                            (fromIntegral msecs)-#if defined(mingw32_HOST_OS)-                          (fromIntegral $ fromEnum $ fdIsSocket fd)-#else-                          0-#endif-  return (toEnum (fromIntegral r))--foreign import ccall safe "fdReady"-  fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt---- ------------------------------------------------------------------------------ Terminal-related stuff--isTerminal :: FD -> IO Bool-isTerminal fd =-#if defined(mingw32_HOST_OS)-    if fdIsSocket fd then return False-                     else is_console (fdFD fd) >>= return.toBool-#else-    c_isatty (fdFD fd) >>= return.toBool-#endif--setEcho :: FD -> Bool -> IO ()-setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on--getEcho :: FD -> IO Bool-getEcho fd = System.Posix.Internals.getEcho (fdFD fd)--setRaw :: FD -> Bool -> IO ()-setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)---- -------------------------------------------------------------------------------- Reading and Writing--fdRead :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int-fdRead fd ptr _offset bytes-  = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0-                (fromIntegral $ clampReadSize bytes)-       ; return (fromIntegral r) }--fdReadNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO (Maybe Int)-fdReadNonBlocking fd ptr _offset bytes = do-  r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr-           0 (fromIntegral $ clampReadSize bytes)-  case fromIntegral r of-    (-1) -> return (Nothing)-    n    -> return (Just n)---fdWrite :: FD -> Ptr Word8 -> Word64 -> Int -> IO ()-fdWrite fd ptr _offset bytes = do-  res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0-          (fromIntegral $ clampWriteSize bytes)-  let res' = fromIntegral res-  if res' < bytes-     then fdWrite fd (ptr `plusPtr` res') (_offset + fromIntegral res') (bytes - res')-     else return ()---- XXX ToDo: this isn't non-blocking-fdWriteNonBlocking :: FD -> Ptr Word8 -> Word64 -> Int -> IO Int-fdWriteNonBlocking fd ptr _offset bytes = do-  res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0-            (fromIntegral $ clampWriteSize bytes)-  return (fromIntegral res)---- -------------------------------------------------------------------------------- FD operations---- Low level routines for reading/writing to (raw)buffers:--#if !defined(mingw32_HOST_OS)--{--NOTE [nonblock]:--Unix has broken semantics when it comes to non-blocking I/O: you can-set the O_NONBLOCK flag on an FD, but it applies to the all other FDs-attached to the same underlying file, pipe or TTY; there's no way to-have private non-blocking behaviour for an FD.  See bug #724.--We fix this by only setting O_NONBLOCK on FDs that we create; FDs that-come from external sources or are exposed externally are left in-blocking mode.  This solution has some problems though.  We can't-completely simulate a non-blocking read without O_NONBLOCK: several-cases are wrong here.  The cases that are wrong:--  * reading/writing to a blocking FD in non-threaded mode.-    In threaded mode, we just make a safe call to read().-    In non-threaded mode we call select() before attempting to read,-    but that leaves a small race window where the data can be read-    from the file descriptor before we issue our blocking read().-  * readRawBufferNoBlock for a blocking FD--NOTE [2363]:--In the threaded RTS we could just make safe calls to read()/write()-for file descriptors in blocking mode without worrying about blocking-other threads, but the problem with this is that the thread will be-uninterruptible while it is blocked in the foreign call.  See #2363.-So now we always call fdReady() before reading, and if fdReady-indicates that there's no data, we call threadWaitRead.---}--readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int-readRawBufferPtr loc !fd !buf !off !len-  | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block-  | otherwise    = do r <- throwErrnoIfMinus1 loc-                                (unsafe_fdReady (fdFD fd) 0 0 0)-                      if r /= 0-                        then read-                        else do threadWaitRead (fromIntegral (fdFD fd)); read-  where-    do_read call = fromIntegral `fmap`-                      throwErrnoIfMinus1RetryMayBlock loc call-                            (threadWaitRead (fromIntegral (fdFD fd)))-    read        = if threaded then safe_read else unsafe_read-    unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)-    safe_read   = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)---- return: -1 indicates EOF, >=0 is bytes read-readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int-readRawBufferPtrNoBlock loc !fd !buf !off !len-  | isNonBlocking fd  = unsafe_read -- unsafe is ok, it can't block-  | otherwise    = do r <- unsafe_fdReady (fdFD fd) 0 0 0-                      if r /= 0 then safe_read-                                else return 0-       -- XXX see note [nonblock]- where-   do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))-                     case r of-                       (-1) -> return 0-                       0    -> return (-1)-                       n    -> return (fromIntegral n)-   unsafe_read  = do_read (c_read (fdFD fd) (buf `plusPtr` off) len)-   safe_read    = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)--writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeRawBufferPtr loc !fd !buf !off !len-  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block-  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0-                     if r /= 0-                        then write-                        else do threadWaitWrite (fromIntegral (fdFD fd)); write-  where-    do_write call = fromIntegral `fmap`-                      throwErrnoIfMinus1RetryMayBlock loc call-                        (threadWaitWrite (fromIntegral (fdFD fd)))-    write         = if threaded then safe_write else unsafe_write-    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)-    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)--writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeRawBufferPtrNoBlock loc !fd !buf !off !len-  | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block-  | otherwise   = do r <- unsafe_fdReady (fdFD fd) 1 0 0-                     if r /= 0 then write-                               else return 0-  where-    do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1))-                       case r of-                         (-1) -> return 0-                         n    -> return (fromIntegral n)-    write         = if threaded then safe_write else unsafe_write-    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)-    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)--isNonBlocking :: FD -> Bool-isNonBlocking fd = fdIsNonBlocking fd /= 0--foreign import ccall unsafe "fdReady"-  unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt--#else /* mingw32_HOST_OS.... */--readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-readRawBufferPtr loc !fd !buf !off !len-  | threaded  = blockingReadRawBufferPtr loc fd buf off len-  | otherwise = asyncReadRawBufferPtr    loc fd buf off len--writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeRawBufferPtr loc !fd !buf !off !len-  | threaded  = blockingWriteRawBufferPtr loc fd buf off len-  | otherwise = asyncWriteRawBufferPtr    loc fd buf off len--readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-readRawBufferPtrNoBlock = readRawBufferPtr--writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeRawBufferPtrNoBlock = writeRawBufferPtr---- Async versions of the read/write primitives, for the non-threaded RTS--asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-asyncReadRawBufferPtr loc !fd !buf !off !len = do-    (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)-                        (fromIntegral len) (buf `plusPtr` off)-    if l == (-1)-      then let sock_errno = c_maperrno_func (fromIntegral rc)-               non_sock_errno = Errno (fromIntegral rc)-               errno = bool non_sock_errno sock_errno (fdIsSocket fd)-           in  ioError (errnoToIOError loc errno Nothing Nothing)-      else return (fromIntegral l)--asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-asyncWriteRawBufferPtr loc !fd !buf !off !len = do-    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)-                  (fromIntegral len) (buf `plusPtr` off)-    if l == (-1)-      then let sock_errno = c_maperrno_func (fromIntegral rc)-               non_sock_errno = Errno (fromIntegral rc)-               errno = bool non_sock_errno sock_errno (fdIsSocket fd)-           in  ioError (errnoToIOError loc errno Nothing Nothing)-      else return (fromIntegral l)---- Blocking versions of the read/write primitives, for the threaded RTS--blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-blockingReadRawBufferPtr loc !fd !buf !off !len-  = throwErrnoIfMinus1Retry loc $ do-        let start_ptr = buf `plusPtr` off-            recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0-            read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len)-        r <- bool read_ret recv_ret (fdIsSocket fd)-        when ((fdIsSocket fd) && (r == -1)) c_maperrno-        return r-      -- We trust read() to give us the correct errno but recv(), as a-      -- Winsock function, doesn't do the errno conversion so if the fd-      -- is for a socket, we do it from GetLastError() ourselves.--blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt-blockingWriteRawBufferPtr loc !fd !buf !off !len-  = throwErrnoIfMinus1Retry loc $ do-        let start_ptr = buf `plusPtr` off-            send_ret = c_safe_send  (fdFD fd) start_ptr (fromIntegral len) 0-            write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)-        r <- bool write_ret send_ret (fdIsSocket fd)-        when (r == -1) c_maperrno-        return r-      -- We don't trust write() to give us the correct errno, and-      -- instead do the errno conversion from GetLastError()-      -- ourselves. The main reason is that we treat ERROR_NO_DATA-      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL-      -- for this case. We need to detect EPIPE correctly, because it-      -- shouldn't be reported as an error when it happens on stdout.-      -- As for send()'s case, Winsock functions don't do errno-      -- conversion in any case so we have to do it ourselves.-      -- That means we're doing the errno conversion no matter if the-      -- fd is from a socket or not.---- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.--- These calls may block, but that's ok.--foreign import WINDOWS_CCONV safe "recv"-   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt--foreign import WINDOWS_CCONV safe "send"-   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt--#endif--foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool---- -------------------------------------------------------------------------------- utils--#if !defined(mingw32_HOST_OS)-throwErrnoIfMinus1RetryOnBlock  :: String -> IO CSsize -> IO CSsize -> IO CSsize-throwErrnoIfMinus1RetryOnBlock loc f on_block  =-  do-    res <- f-    if (res :: CSsize) == -1-      then do-        err <- getErrno-        if err == eINTR-          then throwErrnoIfMinus1RetryOnBlock loc f on_block-          else if err == eWOULDBLOCK || err == eAGAIN-                 then on_block-                 else throwErrno loc-      else return res-#endif---- -------------------------------------------------------------------------------- Locking/unlocking--foreign import ccall unsafe "lockFile"-  lockFile :: Word64 -> Word64 -> Word64 -> CInt -> IO CInt--foreign import ccall unsafe "unlockFile"-  unlockFile :: Word64 -> IO CInt--#if defined(mingw32_HOST_OS)-foreign import ccall unsafe "get_unique_file_info"-  c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()-#endif
− GHC/IO/Handle.hs 
@@ -1,771 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , RecordWildCards-           , NondecreasingIndentation-  #-}-{-# OPTIONS_GHC -Wno-unused-matches #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Handle--- Copyright   :  (c) The University of Glasgow, 1994-2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable------ External API for GHC's Handle implementation-----------------------------------------------------------------------------------module GHC.IO.Handle (-   Handle,-   BufferMode(..),--   mkFileHandle, mkDuplexHandle,--   hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead,-   hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding,-   hFlush, hFlushAll, hDuplicate, hDuplicateTo,--   hClose, hClose_help,--   LockMode(..), hLock, hTryLock,--   HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,-   SeekMode(..), hSeek, hTell,--   hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,-   hSetEcho, hGetEcho, hIsTerminalDevice,--   hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline,-   noNewlineTranslation, universalNewlineMode, nativeNewlineMode,--   hShow,--   hWaitForInput, hGetChar, hGetLine, hGetContents, hGetContents', hPutChar, hPutStr,--   hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking- ) where--import GHC.IO-import GHC.IO.Exception-import GHC.IO.Encoding-import GHC.IO.Buffer-import GHC.IO.BufferedIO ( BufferedIO )-import GHC.IO.Device as IODevice-import GHC.IO.StdHandles-import GHC.IO.SubSystem-import GHC.IO.Handle.Lock-import GHC.IO.Handle.Types-import GHC.IO.Handle.Internals-import GHC.IO.Handle.Text-import qualified GHC.IO.BufferedIO as Buffered--import GHC.Base-import GHC.Exception-import GHC.MVar-import GHC.IORef-import GHC.Show-import GHC.Num-import GHC.Real-import Data.Maybe-import Data.Typeable---- ------------------------------------------------------------------------------ Closing a handle---- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the--- computation finishes, if @hdl@ is writable its buffer is flushed as--- for 'hFlush'.--- Performing 'hClose' on a handle that has already been closed has no effect;--- doing so is not an error.  All other operations on a closed handle will fail.--- If 'hClose' fails for any reason, any further operations (apart from--- 'hClose') on the handle will still fail as if @hdl@ had been successfully--- closed.------ 'hClose' is an /interruptible operation/ in the sense described in--- "Control.Exception". If 'hClose' is interrupted by an asynchronous--- exception in the process of flushing its buffers, then the I/O device--- (e.g., file) will be closed anyway.-hClose :: Handle -> IO ()-hClose = hClose_impl---------------------------------------------------------------------------------- Detecting and changing the size of a file---- | For a handle @hdl@ which attached to a physical file,--- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.--hFileSize :: Handle -> IO Integer-hFileSize handle =-    withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do-    case haType handle_ of-      ClosedHandle              -> ioe_closedHandle-      SemiClosedHandle          -> ioe_semiclosedHandle-      _ -> do flushWriteBuffer handle_-              r <- IODevice.getSize dev-              debugIO $ "hFileSize: " ++ show r ++ " " ++ show handle-              if r /= -1-                then return r-                else ioException (IOError Nothing InappropriateType "hFileSize"-                                  "not a regular file" Nothing Nothing)------ | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.--hSetFileSize :: Handle -> Integer -> IO ()-hSetFileSize handle size =-    withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do-    case haType handle_ of-      ClosedHandle              -> ioe_closedHandle-      SemiClosedHandle          -> ioe_semiclosedHandle-      _ -> do flushWriteBuffer handle_-              IODevice.setSize dev size-              return ()---- ------------------------------------------------------------------------------ Detecting the End of Input---- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns--- 'True' if no further input can be taken from @hdl@ or for a--- physical file, if the current I\/O position is equal to the length of--- the file.  Otherwise, it returns 'False'.------ NOTE: 'hIsEOF' may block, because it has to attempt to read from--- the stream to determine whether there is any more data to be read.--hIsEOF :: Handle -> IO Bool-hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do--  cbuf <- readIORef haCharBuffer-  if not (isEmptyBuffer cbuf) then return False else do--  bbuf <- readIORef haByteBuffer-  if not (isEmptyBuffer bbuf) then return False else do--  -- NB. do no decoding, just fill the byte buffer; see #3808-  (r,bbuf') <- Buffered.fillReadBuffer haDevice bbuf-  if r == 0-     then return True-     else do writeIORef haByteBuffer bbuf'-             return False---- ------------------------------------------------------------------------------ isEOF---- | The computation 'isEOF' is identical to 'hIsEOF',--- except that it works only on 'stdin'.--isEOF :: IO Bool-isEOF = hIsEOF stdin---- ------------------------------------------------------------------------------ Looking ahead---- | Computation 'hLookAhead' returns the next character from the handle--- without removing it from the input buffer, blocking until a character--- is available.------ This operation may fail with:------  * 'System.IO.Error.isEOFError' if the end of file has been reached.--hLookAhead :: Handle -> IO Char-hLookAhead handle =-  wantReadableHandle_ "hLookAhead"  handle hLookAhead_---- ------------------------------------------------------------------------------ Buffering Operations---- Three kinds of buffering are supported: line-buffering,--- block-buffering or no-buffering.  See GHC.IO.Handle for definition and--- further explanation of what the type represent.---- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for--- handle @hdl@ on subsequent reads and writes.------ If the buffer mode is changed from 'BlockBuffering' or--- 'LineBuffering' to 'NoBuffering', then------  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';------  * if @hdl@ is not writable, the contents of the buffer is discarded.------ This operation may fail with:------  * 'System.IO.Error.isPermissionError' if the handle has already been used---    for reading or writing and the implementation does not allow the---    buffering mode to be changed.--hSetBuffering :: Handle -> BufferMode -> IO ()-hSetBuffering handle mode =-  withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do-  case haType of-    ClosedHandle -> ioe_closedHandle-    _ -> do-         if mode == haBufferMode then return handle_ else do--         -- See [note Buffer Sizing] in GHC.IO.Handle.Types--          -- check for errors:-          case mode of-              BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n-              _ -> return ()--          -- for input terminals we need to put the terminal into-          -- cooked or raw mode depending on the type of buffering.-          is_tty <- IODevice.isTerminal haDevice-          when (is_tty && isReadableHandleType haType) $-                case mode of-#if !defined(mingw32_HOST_OS)-        -- 'raw' mode under win32 is a bit too specialised (and troublesome-        -- for most common uses), so simply disable its use here when not using-        -- WinIO.-                  NoBuffering -> IODevice.setRaw haDevice True-#else-                  NoBuffering -> return () <!> IODevice.setRaw haDevice True-#endif-                  _           -> IODevice.setRaw haDevice False--          -- throw away spare buffers, they might be the wrong size-          writeIORef haBuffers BufferListNil--          return Handle__{ haBufferMode = mode,.. }---- -------------------------------------------------------------------------------- hSetEncoding---- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding--- for the handle @hdl@ to @encoding@.  The default encoding when a 'Handle' is--- created is 'System.IO.localeEncoding', namely the default encoding for the--- current locale.------ To create a 'Handle' with no encoding at all, use 'openBinaryFile'.  To--- stop further encoding or decoding on an existing 'Handle', use--- 'hSetBinaryMode'.------ 'hSetEncoding' may need to flush buffered data in order to change--- the encoding.----hSetEncoding :: Handle -> TextEncoding -> IO ()-hSetEncoding hdl encoding =-  withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do-    flushCharBuffer h_-    closeTextCodecs h_-    openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do-    bbuf <- readIORef haByteBuffer-    ref <- newIORef (errorWithoutStackTrace "last_decode")-    return (Handle__{ haLastDecode = ref,-                      haDecoder = mb_decoder,-                      haEncoder = mb_encoder,-                      haCodec   = Just encoding, .. })---- | Return the current 'TextEncoding' for the specified 'Handle', or--- 'Nothing' if the 'Handle' is in binary mode.------ Note that the 'TextEncoding' remembers nothing about the state of--- the encoder/decoder in use on this 'Handle'.  For example, if the--- encoding in use is UTF-16, then using 'hGetEncoding' and--- 'hSetEncoding' to save and restore the encoding may result in an--- extra byte-order-mark being written to the file.----hGetEncoding :: Handle -> IO (Maybe TextEncoding)-hGetEncoding hdl =-  withHandle_ "hGetEncoding" hdl $ \h_@Handle__{..} -> return haCodec---- -------------------------------------------------------------------------------- hFlush---- | The action 'hFlush' @hdl@ causes any items buffered for output--- in handle @hdl@ to be sent immediately to the operating system.------ This operation may fail with:------  * 'System.IO.Error.isFullError' if the device is full;------  * 'System.IO.Error.isPermissionError' if a system resource limit would be---    exceeded. It is unspecified whether the characters in the buffer are---    discarded or retained under these circumstances.--hFlush :: Handle -> IO ()-hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer---- | The action 'hFlushAll' @hdl@ flushes all buffered data in @hdl@,--- including any buffered read data.  Buffered read data is flushed--- by seeking the file position back to the point before the bufferred--- data was read, and hence only works if @hdl@ is seekable (see--- 'hIsSeekable').------ This operation may fail with:------  * 'System.IO.Error.isFullError' if the device is full;------  * 'System.IO.Error.isPermissionError' if a system resource limit would be---    exceeded. It is unspecified whether the characters in the buffer are---    discarded or retained under these circumstances;------  * 'System.IO.Error.isIllegalOperation' if @hdl@ has buffered read data, and---    is not seekable.--hFlushAll :: Handle -> IO ()-hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer---- -------------------------------------------------------------------------------- Repositioning Handles--data HandlePosn = HandlePosn Handle HandlePosition---- | @since 4.1.0.0-instance Eq HandlePosn where-    (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2---- | @since 4.1.0.0-instance Show HandlePosn where-   showsPrec p (HandlePosn h pos) =-        showsPrec p h . showString " at position " . shows pos--  -- HandlePosition is the Haskell equivalent of POSIX' off_t.-  -- We represent it as an Integer on the Haskell side, but-  -- cheat slightly in that hGetPosn calls upon a C helper-  -- that reports the position back via (merely) an Int.-type HandlePosition = Integer---- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of--- @hdl@ as a value of the abstract type 'HandlePosn'.--hGetPosn :: Handle -> IO HandlePosn-hGetPosn handle = do-    posn <- hTell handle-    return (HandlePosn handle posn)---- | If a call to 'hGetPosn' @hdl@ returns a position @p@,--- then computation 'hSetPosn' @p@ sets the position of @hdl@--- to the position it held at the time of the call to 'hGetPosn'.------ This operation may fail with:------  * 'System.IO.Error.isPermissionError' if a system resource limit would be---    exceeded.--hSetPosn :: HandlePosn -> IO ()-hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i---- ------------------------------------------------------------------------------ hSeek--{- Note:- - when seeking using `SeekFromEnd', positive offsets (>=0) means-   seeking at or past EOF.-- - we possibly deviate from the report on the issue of seeking within-   the buffer and whether to flush it or not.  The report isn't exactly-   clear here.--}---- | Computation 'hSeek' @hdl mode i@ sets the position of handle--- @hdl@ depending on @mode@.--- The offset @i@ is given in terms of 8-bit bytes.------ If @hdl@ is block- or line-buffered, then seeking to a position which is not--- in the current buffer will first cause any items in the output buffer to be--- written to the device, and then cause the input buffer to be discarded.--- Some handles may not be seekable (see 'hIsSeekable'), or only support a--- subset of the possible positioning operations (for instance, it may only--- be possible to seek to the end of a tape, or to a positive offset from--- the beginning or current position).--- It is not possible to set a negative I\/O position, or for--- a physical file, an I\/O position beyond the current end-of-file.------ This operation may fail with:------  * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable,---    or does not support the requested seek mode.------  * 'System.IO.Error.isPermissionError' if a system resource limit would be---    exceeded.--hSeek :: Handle -> SeekMode -> Integer -> IO ()-hSeek handle mode offset =-    wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do-    debugIO ("hSeek " ++ show (mode,offset))-    cbuf <- readIORef haCharBuffer-    bbuf <- readIORef haByteBuffer-    debugIO $ "hSeek - bbuf:" ++ summaryBuffer bbuf-    debugIO $ "hSeek - cbuf:" ++ summaryBuffer cbuf--    if isWriteBuffer cbuf-        then do flushWriteBuffer handle_-                new_offset <- IODevice.seek haDevice mode offset-                -- buffer has been updated, need to re-read it-                bbuf1 <- readIORef haByteBuffer-                let bbuf2 = bbuf1{ bufOffset = fromIntegral new_offset }-                debugIO $ "hSeek - seek:: " ++ show offset ++-                          " - " ++ show new_offset-                debugIO $ "hSeek - wr flush bbuf1:" ++ summaryBuffer bbuf2-                writeIORef haByteBuffer bbuf2-        else do--    let r = bufL cbuf; w = bufR cbuf-    if mode == RelativeSeek && isNothing haDecoder &&-       offset >= 0 && offset < fromIntegral (w - r)-        then writeIORef haCharBuffer cbuf{ bufL = r + fromIntegral offset }-        else do--    flushCharReadBuffer handle_-    flushByteReadBuffer handle_-    -- read the updated values-    bbuf2 <- readIORef haByteBuffer-    new_offset <- IODevice.seek haDevice mode offset-    debugIO $ "hSeek after: " ++ show new_offset-    writeIORef haByteBuffer bbuf2{ bufOffset = fromIntegral new_offset }----- | Computation 'hTell' @hdl@ returns the current position of the--- handle @hdl@, as the number of bytes from the beginning of--- the file.  The value returned may be subsequently passed to--- 'hSeek' to reposition the handle to the current position.------ This operation may fail with:------  * 'System.IO.Error.isIllegalOperationError' if the Handle is not seekable.----hTell :: Handle -> IO Integer-hTell handle =-    wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do--      -- TODO: Guard these on Windows-      posn <- if ioSubSystem == IoNative-                         then (fromIntegral . bufOffset) `fmap` readIORef haByteBuffer-                         else IODevice.tell haDevice--      -- we can't tell the real byte offset if there are buffered-      -- Chars, so must flush first:-      flushCharBuffer handle_--      bbuf <- readIORef haByteBuffer-      debugIO ("hTell bbuf (elems=" ++ show (bufferElems bbuf) ++ ")"-               ++ summaryBuffer bbuf)--      let real_posn-           | isWriteBuffer bbuf = posn + fromIntegral (bufferElems bbuf)-           | otherwise          = posn - fromIntegral (bufferElems bbuf)--      cbuf <- readIORef haCharBuffer-      debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))-      debugIO ("   cbuf: " ++ summaryBuffer cbuf ++-               "   bbuf: " ++ summaryBuffer bbuf)--      return real_posn---- -------------------------------------------------------------------------------- Handle Properties---- A number of operations return information about the properties of a--- handle.  Each of these operations returns `True' if the handle has--- the specified property, and `False' otherwise.--hIsOpen :: Handle -> IO Bool-hIsOpen handle =-    withHandle_ "hIsOpen" handle $ \ handle_ -> do-    case haType handle_ of-      ClosedHandle         -> return False-      SemiClosedHandle     -> return False-      _                    -> return True--hIsClosed :: Handle -> IO Bool-hIsClosed handle =-    withHandle_ "hIsClosed" handle $ \ handle_ -> do-    case haType handle_ of-      ClosedHandle         -> return True-      _                    -> return False--{- not defined, nor exported, but mentioned-   here for documentation purposes:--    hSemiClosed :: Handle -> IO Bool-    hSemiClosed h = do-       ho <- hIsOpen h-       hc <- hIsClosed h-       return (not (ho || hc))--}--hIsReadable :: Handle -> IO Bool-hIsReadable (DuplexHandle _ _ _) = return True-hIsReadable handle =-    withHandle_ "hIsReadable" handle $ \ handle_ -> do-    case haType handle_ of-      ClosedHandle         -> ioe_closedHandle-      SemiClosedHandle     -> ioe_semiclosedHandle-      htype                -> return (isReadableHandleType htype)--hIsWritable :: Handle -> IO Bool-hIsWritable (DuplexHandle _ _ _) = return True-hIsWritable handle =-    withHandle_ "hIsWritable" handle $ \ handle_ -> do-    case haType handle_ of-      ClosedHandle         -> ioe_closedHandle-      SemiClosedHandle     -> ioe_semiclosedHandle-      htype                -> return (isWritableHandleType htype)---- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode--- for @hdl@.--hGetBuffering :: Handle -> IO BufferMode-hGetBuffering handle =-    withHandle_ "hGetBuffering" handle $ \ handle_ -> do-    case haType handle_ of-      ClosedHandle         -> ioe_closedHandle-      _ ->-           -- We're being non-standard here, and allow the buffering-           -- of a semi-closed handle to be queried.   -- sof 6/98-          return (haBufferMode handle_)  -- could be stricter..--hIsSeekable :: Handle -> IO Bool-hIsSeekable handle =-    withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do-    case haType of-      ClosedHandle         -> ioe_closedHandle-      SemiClosedHandle     -> ioe_semiclosedHandle-      AppendHandle         -> return False-      _                    -> IODevice.isSeekable haDevice---- -------------------------------------------------------------------------------- Changing echo status---- | Set the echoing status of a handle connected to a terminal.--hSetEcho :: Handle -> Bool -> IO ()-hSetEcho handle on = do-    isT   <- hIsTerminalDevice handle-    if not isT-     then return ()-     else-      withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do-      case haType of-         ClosedHandle -> ioe_closedHandle-         _            -> IODevice.setEcho haDevice on---- | Get the echoing status of a handle connected to a terminal.--hGetEcho :: Handle -> IO Bool-hGetEcho handle = do-    isT   <- hIsTerminalDevice handle-    if not isT-     then return False-     else-       withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do-       case haType of-         ClosedHandle -> ioe_closedHandle-         _            -> IODevice.getEcho haDevice---- | Is the handle connected to a terminal?--hIsTerminalDevice :: Handle -> IO Bool-hIsTerminalDevice handle =-    withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do-     case haType of-       ClosedHandle -> ioe_closedHandle-       _            -> IODevice.isTerminal haDevice---- -------------------------------------------------------------------------------- hSetBinaryMode---- | Select binary mode ('True') or text mode ('False') on a open handle.--- (See also 'openBinaryFile'.)------ This has the same effect as calling 'hSetEncoding' with 'char8', together--- with 'hSetNewlineMode' with 'noNewlineTranslation'.----hSetBinaryMode :: Handle -> Bool -> IO ()-hSetBinaryMode handle bin =-  withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->-    do-         flushCharBuffer h_-         closeTextCodecs h_--         mb_te <- if bin then return Nothing-                         else fmap Just getLocaleEncoding--         openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do--         -- should match the default newline mode, whatever that is-         let nl    | bin       = noNewlineTranslation-                   | otherwise = nativeNewlineMode--         bbuf <- readIORef haByteBuffer-         ref <- newIORef (errorWithoutStackTrace "codec_state", bbuf)--         return Handle__{ haLastDecode = ref,-                          haEncoder  = mb_encoder,-                          haDecoder  = mb_decoder,-                          haCodec    = mb_te,-                          haInputNL  = inputNL nl,-                          haOutputNL = outputNL nl, .. }---- -------------------------------------------------------------------------------- hSetNewlineMode---- | Set the 'NewlineMode' on the specified 'Handle'.  All buffered--- data is flushed first.-hSetNewlineMode :: Handle -> NewlineMode -> IO ()-hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =-  withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{} ->-    do-         flushBuffer h_-         return h_{ haInputNL=i, haOutputNL=o }---- -------------------------------------------------------------------------------- Duplicating a Handle---- | Returns a duplicate of the original handle, with its own buffer.--- The two Handles will share a file pointer, however.  The original--- handle's buffer is flushed, including discarding any input data,--- before the handle is duplicated.--hDuplicate :: Handle -> IO Handle-hDuplicate h@(FileHandle path m) =-  withHandle_' "hDuplicate" h m $ \h_ ->-      dupHandle path h Nothing h_ (Just handleFinalizer)-hDuplicate h@(DuplexHandle path r w) = do-  write_side@(FileHandle _ write_m) <--     withHandle_' "hDuplicate" h w $ \h_ ->-        dupHandle path h Nothing h_ (Just handleFinalizer)-  read_side@(FileHandle _ read_m) <--    withHandle_' "hDuplicate" h r $ \h_ ->-        dupHandle path h (Just write_m) h_  Nothing-  return (DuplexHandle path read_m write_m)--dupHandle :: FilePath-          -> Handle-          -> Maybe (MVar Handle__)-          -> Handle__-          -> Maybe HandleFinalizer-          -> IO Handle-dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do-  -- flush the buffer first, so we don't have to copy its contents-  flushBuffer h_-  case other_side of-    Nothing -> do-       new_dev <- IODevice.dup haDevice-       dupHandle_ new_dev filepath other_side h_ mb_finalizer-    Just r  ->-       withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} ->-         dupHandle_ dev filepath other_side h_ mb_finalizer--dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev-           -> FilePath-           -> Maybe (MVar Handle__)-           -> Handle__-           -> Maybe HandleFinalizer-           -> IO Handle-dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do-   -- XXX wrong!-  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing-  mkHandle new_dev filepath haType True{-buffered-} mb_codec-      NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }-      mb_finalizer other_side---- -------------------------------------------------------------------------------- Replacing a Handle--{- |-Makes the second handle a duplicate of the first handle.  The second-handle will be closed first, if it is not already.--This can be used to retarget the standard Handles, for example:--> do h <- openFile "mystdout" WriteMode->    hDuplicateTo h stdout--}--hDuplicateTo :: Handle -> Handle -> IO ()-hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) =- withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do-   try $ flushWriteBuffer h2_-   withHandle_' "hDuplicateTo" h1 m1 $ \h1_ ->-     dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)-hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do- withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do-   try $ flushWriteBuffer w2_-   withHandle_' "hDuplicateTo" h1 w1 $ \w1_ ->-     dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)- withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do-   try $ flushWriteBuffer r2_-   withHandle_' "hDuplicateTo" h1 r1 $ \r1_ ->-     dupHandleTo path h1 (Just w1) r2_ r1_ Nothing-hDuplicateTo h1 _ =-  ioe_dupHandlesNotCompatible h1--try :: IO () -> IO ()-try io = io `catchException` (const (pure ()) :: SomeException -> IO ())--ioe_dupHandlesNotCompatible :: Handle -> IO a-ioe_dupHandlesNotCompatible h =-   ioException (IOError (Just h) IllegalOperation "hDuplicateTo"-                "handles are incompatible" Nothing Nothing)--dupHandleTo :: FilePath-            -> Handle-            -> Maybe (MVar Handle__)-            -> Handle__-            -> Handle__-            -> Maybe HandleFinalizer-            -> IO Handle__-dupHandleTo filepath h other_side-            hto_@Handle__{haDevice=devTo}-            h_@Handle__{haDevice=dev} mb_finalizer = do-  flushBuffer h_-  case cast devTo of-    Nothing   -> ioe_dupHandlesNotCompatible h-    Just dev' -> do-      _ <- IODevice.dup2 dev dev'-      FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer-      takeMVar m---- ------------------------------------------------------------------------------ showing Handles.------ | 'hShow' is in the 'IO' monad, and gives more comprehensive output--- than the (pure) instance of 'Show' for 'Handle'.--hShow :: Handle -> IO String-hShow h@(FileHandle path _) = showHandle' path False h-hShow h@(DuplexHandle path _ _) = showHandle' path True h--showHandle' :: String -> Bool -> Handle -> IO String-showHandle' filepath is_duplex h =-  withHandle_ "showHandle" h $ \hdl_ ->-    let-     showType | is_duplex = showString "duplex (read-write)"-              | otherwise = shows (haType hdl_)-    in-    return-      (( showChar '{' .-        showHdl (haType hdl_)-            (showString "loc=" . showString filepath . showChar ',' .-             showString "type=" . showType . showChar ',' .-             showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )-      ) "")-   where--    showHdl :: HandleType -> ShowS -> ShowS-    showHdl ht cont =-       case ht of-        ClosedHandle  -> shows ht . showString "}"-        _ -> cont--    showBufMode :: Buffer e -> BufferMode -> ShowS-    showBufMode buf bmo =-      case bmo of-        NoBuffering   -> showString "none"-        LineBuffering -> showString "line"-        BlockBuffering (Just n) -> showString "block " . showParen True (shows n)-        BlockBuffering Nothing  -> showString "block " . showParen True (shows def)-      where-       def :: Int-       def = bufSize buf-
− GHC/IO/Handle.hs-boot 
@@ -1,10 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO.Handle where--import GHC.IO-import GHC.IO.Handle.Types--hFlush :: Handle -> IO ()-
− GHC/IO/Handle/FD.hs 
@@ -1,387 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Handle.FD--- Copyright   :  (c) The University of Glasgow, 1994-2008--- License     :  see libraries/base/LICENSE--- --- Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Handle operations implemented by file descriptors (FDs)-----------------------------------------------------------------------------------module GHC.IO.Handle.FD ( -  stdin, stdout, stderr,-  openFile, withFile,-  openBinaryFile, withBinaryFile,-  openFileBlocking, withFileBlocking,-  mkHandleFromFD, fdToHandle, fdToHandle', handleToFd- ) where--import GHC.Base-import GHC.Show-import Data.Maybe-import Data.Typeable-import Foreign.C.Types-import GHC.MVar-import GHC.IO-import GHC.IO.Encoding-import GHC.IO.Device as IODevice-import GHC.IO.Exception-import GHC.IO.IOMode-import GHC.IO.Handle.Types-import GHC.IO.Handle.Internals-import qualified GHC.IO.FD as FD-import qualified System.Posix.Internals as Posix---- ------------------------------------------------------------------------------ Standard Handles---- Three handles are allocated during program initialisation.  The first--- two manage input or output from the Haskell program's standard input--- or output channel respectively.  The third manages output to the--- standard error channel. These handles are initially open.---- | A handle managing input from the Haskell program's standard input channel.-stdin :: Handle-{-# NOINLINE stdin #-}-stdin = unsafePerformIO $ do-   -- ToDo: acquire lock-   setBinaryMode FD.stdin-   enc <- getLocaleEncoding-   mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)-                nativeNewlineMode{-translate newlines-}-                (Just stdHandleFinalizer) Nothing---- | A handle managing output to the Haskell program's standard output channel.-stdout :: Handle-{-# NOINLINE stdout #-}-stdout = unsafePerformIO $ do-   -- ToDo: acquire lock-   setBinaryMode FD.stdout-   enc <- getLocaleEncoding-   mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)-                nativeNewlineMode{-translate newlines-}-                (Just stdHandleFinalizer) Nothing---- | A handle managing output to the Haskell program's standard error channel.-stderr :: Handle-{-# NOINLINE stderr #-}-stderr = unsafePerformIO $ do-    -- ToDo: acquire lock-   setBinaryMode FD.stderr-   enc <- getLocaleEncoding-   mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-} -                (Just enc)-                nativeNewlineMode{-translate newlines-}-                (Just stdHandleFinalizer) Nothing--stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()-stdHandleFinalizer fp m = do-  h_ <- takeMVar m-  flushWriteBuffer h_-  case haType h_ of -      ClosedHandle -> return ()-      _other       -> closeTextCodecs h_-  putMVar m (ioe_finalizedHandle fp)---- We have to put the FDs into binary mode on Windows to avoid the newline--- translation that the CRT IO library does.-setBinaryMode :: FD.FD -> IO ()-#if defined(mingw32_HOST_OS)-setBinaryMode fd = do _ <- setmode (FD.fdFD fd) True-                      return ()-#else-setBinaryMode _ = return ()-#endif--#if defined(mingw32_HOST_OS)-foreign import ccall unsafe "__hscore_setmode"-  setmode :: CInt -> Bool -> IO CInt-#endif---- ------------------------------------------------------------------------------ Opening and Closing Files--addFilePathToIOError :: String -> FilePath -> IOException -> IOException-addFilePathToIOError fun fp ioe-  = ioe{ ioe_location = fun, ioe_filename = Just fp }---- | Computation 'openFile' @file mode@ allocates and returns a new, open--- handle to manage the file @file@.  It manages input if @mode@--- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',--- and both input and output if mode is 'ReadWriteMode'.------ If the file does not exist and it is opened for output, it should be--- created as a new file.  If @mode@ is 'WriteMode' and the file--- already exists, then it should be truncated to zero length.--- Some operating systems delete empty files, so there is no guarantee--- that the file will exist following an 'openFile' with @mode@--- 'WriteMode' unless it is subsequently written to successfully.--- The handle is positioned at the end of the file if @mode@ is--- 'AppendMode', and otherwise at the beginning (in which case its--- internal position is 0).--- The initial buffer mode is implementation-dependent.------ This operation may fail with:------  * 'System.IO.Error.isAlreadyInUseError' if the file is already open and---    cannot be reopened;------  * 'System.IO.Error.isDoesNotExistError' if the file does not exist or---    (on POSIX systems) is a FIFO without a reader and 'WriteMode' was---    requested; or------  * 'System.IO.Error.isPermissionError' if the user does not have permission---     to open the file.------ On POSIX systems, 'openFile' is an /interruptible operation/ as--- described in "Control.Exception".------ Note: if you will be working with files containing binary data, you'll want to--- be using 'openBinaryFile'.-openFile :: FilePath -> IOMode -> IO Handle-openFile fp im = -  catchException-    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)-    (\e -> ioError (addFilePathToIOError "openFile" fp e))---- | @'withFile' name mode act@ opens a file like 'openFile' and passes--- the resulting handle to the computation @act@.  The handle will be--- closed on exit from 'withFile', whether by normal termination or by--- raising an exception.  If closing the handle raises an exception, then--- this exception will be raised by 'withFile' rather than any exception--- raised by @act@.-withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFile fp im act =-  catchException-    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True act)-    (\e -> ioError (addFilePathToIOError "withFile" fp e))---- | Like 'openFile', but opens the file in ordinary blocking mode.--- 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.------ Note: when blocking happens, an OS thread becomes tied up with the--- processing, so the program must have at least another OS thread if--- it wants to unblock itself. By corollary, a non-threaded runtime--- will need a process-external trigger in order to become unblocked.------ On POSIX systems, 'openFileBlocking' is an /interruptible operation/ as--- described in "Control.Exception".------ @since 4.4.0.0-openFileBlocking :: FilePath -> IOMode -> IO Handle-openFileBlocking fp im =-  catchException-    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)-    (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e))---- | @'withFileBlocking' name mode act@ opens a file like 'openFileBlocking'--- and passes the resulting handle to the computation @act@.  The handle will--- be closed on exit from 'withFileBlocking', whether by normal termination or--- by raising an exception.  If closing the handle raises an exception, then--- this exception will be raised by 'withFile' rather than any exception raised--- by @act@.-withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFileBlocking fp im act =-  catchException-    (withFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False act)-    (\e -> ioError (addFilePathToIOError "withFileBlocking" fp e))---- | Like 'openFile', but open the file in binary mode.--- On Windows, reading a file in text mode (which is the default)--- will translate CRLF to LF, and writing will translate LF to CRLF.--- This is usually what you want with text files.  With binary files--- this is undesirable; also, as usual under Microsoft operating systems,--- text mode treats control-Z as EOF.  Binary mode turns off all special--- treatment of end-of-line and end-of-file characters.--- (See also 'System.IO.hSetBinaryMode'.)---- On POSIX systems, 'openBinaryFile' is an /interruptible operation/ as--- described in "Control.Exception".-openBinaryFile :: FilePath -> IOMode -> IO Handle-openBinaryFile fp m =-  catchException-    (openFile' fp m True True)-    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))---- | A version of `openBinaryFile` that takes an action to perform--- with the handle. If an exception occurs in the action, then--- the file will be closed automatically. The action /should/--- close the file when finished with it so the file does not remain--- open until the garbage collector collects the handle.-withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withBinaryFile fp im act =-  catchException-    (withFile' fp im True True act)-    (\e -> ioError (addFilePathToIOError "withBinaryFile" fp e))---- | Open a file and perform an action with it. If the action throws an--- exception, then the file will be closed. If the last argument is 'True',--- then the file will be closed on successful completion as well. We use this to--- implement both the `withFile` family of functions (via `withFile'`) and the--- `openFile` family (via `openFile'`).-withOpenFile' :: String -> IOMode -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r-withOpenFile' filepath iomode binary non_blocking act close_finally =-  -- first open the file to get an FD-  FD.openFileWith filepath iomode non_blocking (\fd fd_type -> do--      mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding--      -- Then use it to make a Handle. If this fails, openFileWith-      -- will take care of closing the file.-      mkHandleFromFDNoFinalizer fd fd_type filepath iomode-                       False {- do not *set* non-blocking mode -}-                       mb_codec)--    -- Add a finalizer to the handle. This is done under a mask,-    -- so there are no asynchronous exceptions, and (satisfying-    -- the conditions of openFileWith), addHandleFinalizer-    -- cannot throw a synchronous exception.-    (\restore hndl -> do-        addHandleFinalizer hndl handleFinalizer-        r <- restore (act hndl) `onException` hClose_impl hndl-        when close_finally $ hClose_impl hndl-        pure r-        )--        -- ASSERT: if we just created the file, then fdToHandle' won't fail-        -- (so we don't need to worry about removing the newly created file-        --  in the event of an error).---- | Open a file and perform an action with it. When the action--- completes or throws/receives an exception, the file will be closed.-withFile' :: String -> IOMode -> Bool -> Bool -> (Handle -> IO r) -> IO r-withFile' filepath iomode binary non_blocking act =-  withOpenFile' filepath iomode binary non_blocking act True--openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle-openFile' filepath iomode binary non_blocking =-  withOpenFile' filepath iomode binary non_blocking pure False---- ------------------------------------------------------------------------------ Converting file descriptors from/to Handles--mkHandleFromFDNoFinalizer-   :: FD.FD-   -> IODeviceType-   -> FilePath  -- a string describing this file descriptor (e.g. the filename)-   -> IOMode-   -> Bool      --  *set* non-blocking mode on the FD-   -> Maybe TextEncoding-   -> IO Handle--mkHandleFromFDNoFinalizer fd0 fd_type filepath iomode set_non_blocking mb_codec-  = do-#if !defined(mingw32_HOST_OS)-    -- turn on non-blocking mode-    fd <- if set_non_blocking -             then FD.setNonBlockingMode fd0 True-             else return fd0-#else-    let _ = set_non_blocking -- warning suppression-    fd <- return fd0-#endif--    let nl | isJust mb_codec = nativeNewlineMode-           | otherwise       = noNewlineTranslation--    case fd_type of-        Directory -> -           ioException (IOError Nothing InappropriateType "openFile"-                           "is a directory" Nothing Nothing)--        Stream-           -- only *Streams* can be DuplexHandles.  Other read/write-           -- Handles must share a buffer.-           | ReadWriteMode <- iomode -> -                mkDuplexHandleNoFinalizer fd filepath mb_codec nl--        _other -> -           mkFileHandleNoFinalizer fd filepath iomode mb_codec nl--mkHandleFromFD-   :: FD.FD-   -> IODeviceType-   -> FilePath  -- a string describing this file descriptor (e.g. the filename)-   -> IOMode-   -> Bool      --  *set* non-blocking mode on the FD-   -> Maybe TextEncoding-   -> IO Handle-mkHandleFromFD fd0 fd_type filepath iomode set_non_blocking mb_codec = do-  h <- mkHandleFromFDNoFinalizer fd0 fd_type filepath iomode-                                 set_non_blocking mb_codec-  addHandleFinalizer h handleFinalizer-  pure h---- | Old API kept to avoid breaking clients-fdToHandle' :: CInt-            -> Maybe IODeviceType-            -> Bool -- is_socket on Win, non-blocking on Unix-            -> FilePath-            -> IOMode-            -> Bool -- binary-            -> IO Handle-fdToHandle' fdint mb_type is_socket filepath iomode binary = do-  let mb_stat = case mb_type of-                        Nothing          -> Nothing-                          -- mkFD will do the stat:-                        Just RegularFile -> Nothing-                          -- no stat required for streams etc.:-                        Just other       -> Just (other,0,0)-  (fd,fd_type) <- FD.mkFD fdint iomode mb_stat-                       is_socket-                       is_socket-  enc <- if binary then return Nothing else fmap Just getLocaleEncoding-  mkHandleFromFD fd fd_type filepath iomode is_socket enc----- | Turn an existing file descriptor into a Handle.  This is used by--- various external libraries to make Handles.------ Makes a binary Handle.  This is for historical reasons; it should--- probably be a text Handle with the default encoding and newline--- translation instead.-fdToHandle :: Posix.FD -> IO Handle-fdToHandle fdint = do-   iomode <- Posix.fdGetMode fdint-   (fd,fd_type) <- FD.mkFD fdint iomode Nothing-            False{-is_socket-} -              -- NB. the is_socket flag is False, meaning that:-              --  on Windows we're guessing this is not a socket (XXX)-            False{-is_nonblock-}-              -- file descriptors that we get from external sources are-              -- not put into non-blocking mode, because that would affect-              -- other users of the file descriptor-   let fd_str = "<file descriptor: " ++ show fd ++ ">"-   mkHandleFromFD fd fd_type fd_str iomode False{-non-block-} -                  Nothing -- bin mode---- | Turn an existing Handle into a file descriptor. This function throws an--- IOError if the Handle does not reference a file descriptor.-handleToFd :: Handle -> IO FD.FD-handleToFd h = case h of-  FileHandle _ mv -> do-    Handle__{haDevice = dev} <- readMVar mv-    case cast dev of-      Just fd -> return fd-      Nothing -> throwErr "not a file descriptor"-  DuplexHandle{} -> throwErr "not a file handle"-  where-    throwErr msg = ioException $ IOError (Just h)-      InappropriateType "handleToFd" msg Nothing Nothing----- ------------------------------------------------------------------------------ Are files opened by default in text or binary mode, if the user doesn't--- specify?--dEFAULT_OPEN_IN_BINARY_MODE :: Bool-dEFAULT_OPEN_IN_BINARY_MODE = False
− GHC/IO/Handle/FD.hs-boot 
@@ -1,10 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO.Handle.FD where--import GHC.IO.Handle.Types---- used in GHC.Conc, which is below GHC.IO.Handle.FD-stdout :: Handle-
− GHC/IO/Handle/Internals.hs 
@@ -1,1084 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude-           , RecordWildCards-           , BangPatterns-           , NondecreasingIndentation-           , RankNTypes-  #-}-{-# OPTIONS_GHC -Wno-unused-matches #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Handle.Internals--- Copyright   :  (c) The University of Glasgow, 1994-2001--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ This module defines the basic operations on I\/O \"handles\".  All--- of the operations defined here are independent of the underlying--- device.-----------------------------------------------------------------------------------module GHC.IO.Handle.Internals (-  withHandle, withHandle', withHandle_,-  withHandle__', withHandle_', withAllHandles__,-  wantWritableHandle, wantReadableHandle, wantReadableHandle_,-  wantSeekableHandle,--  mkHandle,-  mkFileHandle, mkFileHandleNoFinalizer, mkDuplexHandle, mkDuplexHandleNoFinalizer,-  addHandleFinalizer,-  openTextEncoding, closeTextCodecs, initBufferState,-  dEFAULT_CHAR_BUFFER_SIZE,--  flushBuffer, flushWriteBuffer, flushCharReadBuffer,-  flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer,--  readTextDevice, writeCharBuffer, readTextDeviceNonBlocking,-  decodeByteBuf,--  augmentIOError,-  ioe_closedHandle, ioe_semiclosedHandle,-  ioe_EOF, ioe_notReadable, ioe_notWritable,-  ioe_finalizedHandle, ioe_bufsiz,--  hClose_impl, hClose_help, hLookAhead_,--  HandleFinalizer, handleFinalizer,--  debugIO, traceIO- ) where--import GHC.IO-import GHC.IO.IOMode-import GHC.IO.Encoding as Encoding-import GHC.IO.Encoding.Types (CodeBuffer)-import GHC.IO.Handle.Types-import GHC.IO.Buffer-import GHC.IO.BufferedIO (BufferedIO)-import GHC.IO.Exception-import GHC.IO.Device (IODevice, RawIO, SeekMode(..))-import GHC.IO.SubSystem ((<!>), isWindowsNativeIO)-import qualified GHC.IO.Device as IODevice-import qualified GHC.IO.BufferedIO as Buffered--import GHC.Conc.Sync-import GHC.Real-import GHC.Base-import GHC.Exception-import GHC.Num          ( Num(..) )-import GHC.Show-import GHC.IORef-import GHC.MVar-import Data.Typeable-import Data.Maybe-import Foreign-import System.Posix.Internals hiding (FD)--import Foreign.C--c_DEBUG_DUMP :: Bool-c_DEBUG_DUMP = False---- ------------------------------------------------------------------------------ Creating a new handle--type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()---- | Add a finalizer to a 'Handle'. Specifically, the finalizer--- will be added to the 'MVar' of a file handle or the write-side--- 'MVar' of a duplex handle. See Handle Finalizers for details.-addHandleFinalizer :: Handle -> HandleFinalizer -> IO ()-addHandleFinalizer handle finalizer = do-  debugIO $ "Registering finalizer: " ++ show filepath-  addMVarFinalizer mv (finalizer filepath mv)-  where-    !(filepath, !mv) = case handle of-      FileHandle fp m -> (fp, m)-      DuplexHandle fp _ write_m -> (fp, write_m)----- ------------------------------------------------------------------------------ Working with Handles--{--In the concurrent world, handles are locked during use.  This is done-by wrapping an MVar around the handle which acts as a mutex over-operations on the handle.--To avoid races, we use the following bracketing operations.  The idea-is to obtain the lock, do some operation and replace the lock again,-whether the operation succeeded or failed.  We also want to handle the-case where the thread receives an exception while processing the IO-operation: in these cases we also want to relinquish the lock.--There are three versions of @withHandle@: corresponding to the three-possible combinations of:--        - the operation may side-effect the handle-        - the operation may return a result--If the operation generates an error or an exception is raised, the-original handle is always replaced.--}--{-# INLINE withHandle #-}-withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a-withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act-withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act--withHandle' :: String -> Handle -> MVar Handle__-   -> (Handle__ -> IO (Handle__,a)) -> IO a-withHandle' fun h m act =- mask_ $ do-   (h',v)  <- do_operation fun h act m-   checkHandleInvariants h'-   putMVar m h'-   return v--{-# INLINE withHandle_ #-}-withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a-withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act-withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act--withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a-withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do-                              a <- act h_-                              return (h_,a)--withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()-withAllHandles__ fun h@(FileHandle _ m)     act = withHandle__' fun h m act-withAllHandles__ fun h@(DuplexHandle _ r w) act = do-  withHandle__' fun h r act-  withHandle__' fun h w act--withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)-              -> IO ()-withHandle__' fun h m act =- mask_ $ do-   h'  <- do_operation fun h act m-   checkHandleInvariants h'-   putMVar m h'-   return ()--do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a-do_operation fun h act m = do-  h_ <- takeMVar m-  checkHandleInvariants h_-  act h_ `catchException` handler h_-  where-    handler h_ e = do-      putMVar m h_-      case () of-        _ | Just ioe <- fromException e ->-            ioError (augmentIOError ioe fun h)-        _ | Just async_ex <- fromException e -> do -- see Note [async]-            let _ = async_ex :: SomeAsyncException-            t <- myThreadId-            throwTo t e-            do_operation fun h act m-        _otherwise ->-            throwIO e---- Note [async]------ If an asynchronous exception is raised during an I/O operation,--- normally it is fine to just re-throw the exception synchronously.--- However, if we are inside an unsafePerformIO or an--- unsafeInterleaveIO, this would replace the enclosing thunk with the--- exception raised, which is wrong (#3997).  We have to release the--- lock on the Handle, but what do we replace the thunk with?  What--- should happen when the thunk is subsequently demanded again?------ The only sensible choice we have is to re-do the IO operation on--- resumption, but then we have to be careful in the IO library that--- this is always safe to do.  In particular we should------    never perform any side-effects before an interruptible operation------ because the interruptible operation may raise an asynchronous--- exception, which may cause the operation and its side effects to be--- subsequently performed again.------ Re-doing the IO operation is achieved by:---   - using throwTo to re-throw the asynchronous exception asynchronously---     in the current thread---   - on resumption, it will be as if throwTo returns.  In that case, we---     recursively invoke the original operation (see do_operation above).------ Interruptible operations in the I/O library are:---    - threadWaitRead/threadWaitWrite---    - fillReadBuffer/flushWriteBuffer---    - readTextDevice/writeTextDevice--augmentIOError :: IOException -> String -> Handle -> IOException-augmentIOError ioe@IOError{ ioe_filename = fp } fun h-  = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }-  where filepath-          | Just _ <- fp = fp-          | otherwise = case h of-                          FileHandle path _     -> Just path-                          DuplexHandle path _ _ -> Just path---- ------------------------------------------------------------------------------ Wrapper for write operations.---- If we already have a writeable handle just run the action.--- If we have a read only handle we throw an exception.--- If we have a read/write handle in read mode we:--- * Seek to the unread (from the users PoV) position and---   change the handles buffer to a write buffer.-wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a-wantWritableHandle fun h@(FileHandle _ m) act-  = wantWritableHandle' fun h m act-wantWritableHandle fun h@(DuplexHandle _ _ m) act-  = wantWritableHandle' fun h m act-    -- we know it's not a ReadHandle or ReadWriteHandle, but we have to-    -- check for ClosedHandle/SemiClosedHandle. (#4808)--wantWritableHandle'-        :: String -> Handle -> MVar Handle__-        -> (Handle__ -> IO a) -> IO a-wantWritableHandle' fun h m act-   = withHandle_' fun h m (checkWritableHandle act)--checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a-checkWritableHandle act h_@Handle__{..}-  = case haType of-      ClosedHandle         -> ioe_closedHandle-      SemiClosedHandle     -> ioe_semiclosedHandle-      ReadHandle           -> ioe_notWritable-      ReadWriteHandle      -> do-        buf <- readIORef haCharBuffer-        when (not (isWriteBuffer buf)) $ do-           flushCharReadBuffer h_-           flushByteReadBuffer h_-           buf <- readIORef haCharBuffer-           writeIORef haCharBuffer buf{ bufState = WriteBuffer }-           buf <- readIORef haByteBuffer-           buf' <- Buffered.emptyWriteBuffer haDevice buf-           writeIORef haByteBuffer buf'-        act h_-      AppendHandle         -> act h_-      WriteHandle          -> act h_---- ------------------------------------------------------------------------------ Wrapper for read operations.--wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a-wantReadableHandle fun h act =-  withHandle fun h (checkReadableHandle act)--wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a-wantReadableHandle_ fun h@(FileHandle  _ m)   act-  = wantReadableHandle' fun h m act-wantReadableHandle_ fun h@(DuplexHandle _ m _) act-  = wantReadableHandle' fun h m act-    -- we know it's not a WriteHandle or ReadWriteHandle, but we have to-    -- check for ClosedHandle/SemiClosedHandle. (#4808)--wantReadableHandle'-        :: String -> Handle -> MVar Handle__-        -> (Handle__ -> IO a) -> IO a-wantReadableHandle' fun h m act-  = withHandle_' fun h m (checkReadableHandle act)--checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a-checkReadableHandle act h_@Handle__{..} =-    case haType of-      ClosedHandle         -> ioe_closedHandle-      SemiClosedHandle     -> ioe_semiclosedHandle-      AppendHandle         -> ioe_notReadable-      WriteHandle          -> ioe_notReadable-      ReadWriteHandle      -> do-          -- a read/write handle and we want to read from it.  We must-          -- flush all buffered write data first.-          bbuf <- readIORef haByteBuffer-          when (isWriteBuffer bbuf) $ do-             when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_-             cbuf' <- readIORef haCharBuffer-             writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }-             bbuf <- readIORef haByteBuffer-             writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }-          act h_-      _other               -> act h_---- ------------------------------------------------------------------------------ Wrapper for seek operations.--wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a-wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =-  ioException (IOError (Just h) IllegalOperation fun-                   "handle is not seekable" Nothing Nothing)-wantSeekableHandle fun h@(FileHandle _ m) act =-  withHandle_' fun h m (checkSeekableHandle act)--checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a-checkSeekableHandle act handle_@Handle__{haDevice=dev} =-    case haType handle_ of-      ClosedHandle      -> ioe_closedHandle-      SemiClosedHandle  -> ioe_semiclosedHandle-      AppendHandle      -> ioe_notSeekable-      _ -> do b <- IODevice.isSeekable dev-              if b then act handle_-                   else ioe_notSeekable---- -------------------------------------------------------------------------------- Handy IOErrors--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-   (IOError Nothing IllegalOperation ""-        "handle is not open for reading" Nothing Nothing)-ioe_notWritable = ioException-   (IOError Nothing IllegalOperation ""-        "handle is not open for writing" Nothing Nothing)-ioe_notSeekable = ioException-   (IOError Nothing IllegalOperation ""-        "handle is not seekable" Nothing Nothing)-ioe_cannotFlushNotSeekable = ioException-   (IOError Nothing IllegalOperation ""-      "cannot flush the read buffer: underlying device is not seekable"-        Nothing Nothing)--ioe_finalizedHandle :: FilePath -> Handle__-ioe_finalizedHandle fp = throw-   (IOError Nothing IllegalOperation ""-        "handle is finalized" Nothing (Just fp))--ioe_bufsiz :: Int -> IO a-ioe_bufsiz n = ioException-   (IOError Nothing InvalidArgument "hSetBuffering"-        ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)-                                -- 9 => should be parens'ified.---- ------------------------------------------------------------------------------ Wrapper for Handle encoding/decoding.---- The interface for TextEncoding changed so that a TextEncoding doesn't raise--- an exception if it encounters an invalid sequence. Furthermore, encoding--- returns a reason as to why encoding stopped, letting us know if it was due--- to input/output underflow or an invalid sequence.------ This code adapts this elaborated interface back to the original TextEncoding--- interface.------ FIXME: it is possible that Handle code using the haDecoder/haEncoder fields--- could be made clearer by using the 'encode' interface directly. I have not--- looked into this.--streamEncode :: BufferCodec from to state-             -> Buffer from -> Buffer to-             -> IO (Buffer from, Buffer to)-streamEncode codec from to = fmap (\(_, from', to') -> (from', to')) $ recoveringEncode codec from to---- | Just like 'encode', but interleaves calls to 'encode' with calls to 'recover' in order to make as much progress as possible-recoveringEncode :: BufferCodec from to state -> CodeBuffer from to-recoveringEncode codec from to = go from to-  where-    go from to = do-      (why, from', to') <- encode codec from to-      -- When we are dealing with Handles, we don't care about input/output-      -- underflow particularly, and we want to delay errors about invalid-      -- sequences as far as possible.-      case why of-        InvalidSequence | bufL from == bufL from' -> do-          -- NB: it is OK to call recover here. Because we saw InvalidSequence, by the invariants-          -- on "encode" it must be the case that there is at least one elements available in the output-          -- buffer. Furthermore, clearly there is at least one element in the input buffer since we found-          -- something invalid there!-          (from', to') <- recover codec from' to'-          go from' to'-        _ -> return (why, from', to')---- -------------------------------------------------------------------------------- Handle Finalizers---- For a duplex handle, we arrange that the read side points to the write side--- (and hence keeps it alive if the read side is alive).  This is done by--- having the haOtherSide field of the read side point to the read side.--- The finalizer is then placed on the write side, and the handle only gets--- finalized once, when both sides are no longer required.---- NOTE about finalized handles: It's possible that a handle can be--- finalized and then we try to use it later, for example if the--- handle is referenced from another finalizer, or from a thread that--- has become unreferenced and then resurrected (arguably in the--- latter case we shouldn't finalize the Handle...).  Anyway,--- we try to emit a helpful message which is better than nothing.------ [later; 8/2010] However, a program like this can yield a strange--- error message:------   main = writeFile "out" loop---   loop = let x = x in x------ because the main thread and the Handle are both unreachable at the--- same time, the Handle may get finalized before the main thread--- receives the NonTermination exception, and the exception handler--- will then report an error.  We'd rather this was not an error and--- the program just prints "<<loop>>".--handleFinalizer :: FilePath -> MVar Handle__ -> IO ()-handleFinalizer fp m = do-  handle_ <- takeMVar m-  (handle_', _) <- hClose_help handle_-  putMVar m handle_'-  return ()---- ------------------------------------------------------------------------------ Allocating buffers---- using an 8k char buffer instead of 32k improved performance for a--- basic "cat" program by ~30% for me.  --SDM-dEFAULT_CHAR_BUFFER_SIZE :: Int-dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar)--getCharBuffer :: IODevice dev => dev -> BufferState-              -> IO (IORef CharBuffer, BufferMode)-getCharBuffer dev state = do-  buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state-  ioref  <- newIORef buffer-  is_tty <- IODevice.isTerminal dev--  let buffer_mode-         | is_tty    = LineBuffering-         | otherwise = BlockBuffering Nothing--  return (ioref, buffer_mode)--mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)-mkUnBuffer state = do-  buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state-              --  See [note Buffer Sizing], GHC.IO.Handle.Types-  ref <- newIORef buffer-  return (ref, NoBuffering)---- -------------------------------------------------------------------------------- Flushing buffers---- | syncs the file with the buffer, including moving the--- file pointer backwards in the case of a read buffer.  This can fail--- on a non-seekable read Handle.-flushBuffer :: Handle__ -> IO ()-flushBuffer h_@Handle__{..} = do-  buf <- readIORef haCharBuffer-  case bufState buf of-    ReadBuffer -> do-        flushCharReadBuffer h_-        flushByteReadBuffer h_-    WriteBuffer ->-        flushByteWriteBuffer h_---- | flushes the Char buffer only.  Works on all Handles.-flushCharBuffer :: Handle__ -> IO ()-flushCharBuffer h_@Handle__{..} = do-  cbuf <- readIORef haCharBuffer-  case bufState cbuf of-    ReadBuffer ->-        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 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-  when (isWriteBuffer buf) $ flushByteWriteBuffer h_--flushByteWriteBuffer :: Handle__ -> IO ()-flushByteWriteBuffer h_@Handle__{..} = do-  bbuf <- readIORef haByteBuffer-  when (not (isEmptyBuffer bbuf)) $ do-    bbuf' <- Buffered.flushWriteBuffer haDevice bbuf-    debugIO ("flushByteWriteBuffer: bbuf=" ++ summaryBuffer bbuf')-    writeIORef haByteBuffer bbuf'---- write the contents of the CharBuffer to the Handle__.--- The data will be encoded and pushed to the byte buffer,--- flushing if the buffer becomes full.--- Data is written to the handles current buffer offset.-writeCharBuffer :: Handle__ -> CharBuffer -> IO ()-writeCharBuffer h_@Handle__{..} !cbuf = do-  ---  bbuf <- readIORef haByteBuffer--  debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++-        " bbuf=" ++ summaryBuffer bbuf)--  (cbuf',bbuf') <- case haEncoder of-    Nothing      -> latin1_encode cbuf bbuf-    Just encoder -> (streamEncode encoder) cbuf bbuf--  debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++-        " bbuf=" ++ summaryBuffer bbuf')--          -- flush the byte buffer if it is full-  if isFullBuffer bbuf'-          --  or we made no progress-     || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf-          -- or the byte buffer has more elements than the user wanted buffered-     || (case haBufferMode of-          BlockBuffering (Just s) -> bufferElems bbuf' >= s-          NoBuffering -> True-          _other -> False)-    then do-      bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'-      writeIORef haByteBuffer bbuf''-      debugIO ("writeCharBuffer after flushing: cbuf=" ++ summaryBuffer bbuf'')-    else-      writeIORef haByteBuffer bbuf'--  if not (isEmptyBuffer cbuf')-     then writeCharBuffer h_ cbuf'-     else return ()---- -------------------------------------------------------------------------------- Flushing read buffers---- It is always possible to flush the Char buffer back to the byte buffer.-flushCharReadBuffer :: Handle__ -> IO ()-flushCharReadBuffer Handle__{..} = do-  cbuf <- readIORef haCharBuffer-  if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do--  -- haLastDecode is the byte buffer just before we did our last batch of-  -- decoding.  We're going to re-decode the bytes up to the current char,-  -- to find out where we should revert the byte buffer to.-  (codec_state, bbuf0) <- readIORef haLastDecode--  cbuf0 <- readIORef haCharBuffer-  writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }--  -- if we haven't used any characters from the char buffer, then just-  -- re-install the old byte buffer.-  if bufL cbuf0 == 0-     then do writeIORef haByteBuffer bbuf0-             return ()-     else do--  case haDecoder of-    Nothing ->-      writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }-      -- no decoder: the number of bytes to decode is the same as the-      -- number of chars we have used up.--    Just decoder -> do-      debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++-               " cbuf=" ++ summaryBuffer cbuf0)--      -- restore the codec state-      setState decoder codec_state--      (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0-                               cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }--      -- We should not need to update the offset here. The bytebuffer contains the-      -- offset for the next read after it's used up. But this function only flushes-      -- the char buffer.-      -- let bbuf2 = bbuf1 -- {bufOffset = bufOffset bbuf1 - fromIntegral (bufL bbuf1)}-      -- debugIO ("finished, bbuf=" ++ summaryBuffer bbuf2 ++-      --          " cbuf=" ++ summaryBuffer cbuf1)--      writeIORef haByteBuffer bbuf1----- When flushing the byte read buffer, we seek backwards by the number--- of characters in the buffer.  The file descriptor must therefore be--- seekable: attempting to flush the read buffer on an unseekable--- handle is not allowed.--flushByteReadBuffer :: Handle__ -> IO ()-flushByteReadBuffer h_@Handle__{..} = do-  bbuf <- readIORef haByteBuffer--  if isEmptyBuffer bbuf then return () else do--  seekable <- IODevice.isSeekable haDevice-  when (not seekable) $ ioe_cannotFlushNotSeekable--  let seek = negate (bufR bbuf - bufL bbuf)-  let offset = bufOffset bbuf - fromIntegral (bufR bbuf - bufL bbuf)--  debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)-  debugIO ("flushByteReadBuffer: " ++ summaryBuffer bbuf)--  let mIOSeek   = IODevice.seek haDevice RelativeSeek (fromIntegral seek)-  -- win-io doesn't need this, but it allows us to error out on invalid offsets-  let winIOSeek = IODevice.seek haDevice AbsoluteSeek (fromIntegral offset)--  _ <- mIOSeek <!> winIOSeek  -- execute one of these two seek functions--  writeIORef haByteBuffer bbuf{ bufL=0, bufR=0, bufOffset=offset }---- ------------------------------------------------------------------------------- Making Handles--{- Note [Making offsets for append]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  The WINIO subysstem keeps track of offsets for handles-  on the Haskell side of things instead of letting the OS-  handle it. This requires us to establish the correct offset-  for a handle on creation. This is usually zero but slightly-  more tedious for append modes. There we fall back on IODevice-  functionality to establish the size of the file and then set-  the offset accordingly. This is only required for WINIO.--}---- | Make an @'MVar' 'Handle__'@ for use in a 'Handle'. This function--- does not install a finalizer; that must be done by the caller.-mkHandleMVar :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev-         -> FilePath-         -> HandleType-         -> Bool                     -- buffered?-         -> Maybe TextEncoding-         -> NewlineMode-         -> Maybe (MVar Handle__)-         -> IO (MVar Handle__)-mkHandleMVar dev filepath ha_type buffered mb_codec nl other_side =-   openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do--   let !buf_state = initBufferState ha_type-   !bbuf_no_offset <- (Buffered.newBuffer dev buf_state)-   !buf_offset <- initHandleOffset-   let !bbuf = bbuf_no_offset { bufOffset = buf_offset}--   bbufref <- newIORef bbuf-   last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf)--   (cbufref,bmode) <--         if buffered then getCharBuffer dev buf_state-                     else mkUnBuffer buf_state--   spares <- newIORef BufferListNil-   debugIO $ "making handle for " ++ filepath-   newMVar $ Handle__ { haDevice = dev,-                        haType = ha_type,-                        haBufferMode = bmode,-                        haByteBuffer = bbufref,-                        haLastDecode = last_decode,-                        haCharBuffer = cbufref,-                        haBuffers = spares,-                        haEncoder = mb_encoder,-                        haDecoder = mb_decoder,-                        haCodec = mb_codec,-                        haInputNL = inputNL nl,-                        haOutputNL = outputNL nl,-                        haOtherSide = other_side-                      }-  where-    -- See Note [Making offsets for append]-    initHandleOffset-      | isAppendHandleType ha_type-      , isWindowsNativeIO = do-          size <- IODevice.getSize dev-          return (fromIntegral size :: Word64)-      | otherwise = return 0--mkHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev-         -> FilePath-         -> HandleType-         -> Bool                     -- buffered?-         -> Maybe TextEncoding-         -> NewlineMode-         -> Maybe HandleFinalizer-         -> Maybe (MVar Handle__)-         -> IO Handle-mkHandle dev filepath ha_type buffered mb_codec nl mb_finalizer other_side = do-  mv <- mkHandleMVar dev filepath ha_type buffered mb_codec nl other_side-  let handle = FileHandle filepath mv-  case mb_finalizer of-    Nothing -> pure ()-    Just finalizer -> addHandleFinalizer handle finalizer-  pure handle---- | makes a new 'Handle' without a finalizer.-mkFileHandleNoFinalizer-             :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)-             => dev -- ^ the underlying IO device, which must support-                    -- 'IODevice', 'BufferedIO' and 'Typeable'-             -> FilePath-                    -- ^ a string describing the 'Handle', e.g. the file-                    -- path for a file.  Used in error messages.-             -> IOMode-                    -- The mode in which the 'Handle' is to be used-             -> Maybe TextEncoding-                    -- Create the 'Handle' with no text encoding?-             -> NewlineMode-                    -- Translate newlines?-             -> IO Handle-mkFileHandleNoFinalizer dev filepath iomode mb_codec tr_newlines = do-   mv <- mkHandleMVar dev filepath (ioModeToHandleType iomode) True{-buffered-}-                      mb_codec-                      tr_newlines-                      Nothing{-other_side-}-   pure (FileHandle filepath mv)---- | makes a new 'Handle'-mkFileHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)-             => dev -- ^ the underlying IO device, which must support-                    -- 'IODevice', 'BufferedIO' and 'Typeable'-             -> FilePath-                    -- ^ a string describing the 'Handle', e.g. the file-                    -- path for a file.  Used in error messages.-             -> IOMode-                    -- The mode in which the 'Handle' is to be used-             -> Maybe TextEncoding-                    -- Create the 'Handle' with no text encoding?-             -> NewlineMode-                    -- Translate newlines?-             -> IO Handle--mkFileHandle dev filepath iomode mb_codec tr_newlines = do-   h <- mkFileHandleNoFinalizer dev filepath iomode mb_codec tr_newlines-   addHandleFinalizer h handleFinalizer-   pure h---- | like 'mkFileHandle', except that a 'Handle' is created with two--- independent buffers, one for reading and one for writing.  Used for--- full-duplex streams, such as network sockets.-mkDuplexHandleNoFinalizer ::-  (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)-     => dev -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle-mkDuplexHandleNoFinalizer dev filepath mb_codec tr_newlines = do--  write_m <--       mkHandleMVar dev filepath WriteHandle True mb_codec-                        tr_newlines-                        Nothing -- no other side--  read_m <--      mkHandleMVar dev filepath ReadHandle True mb_codec-                        tr_newlines-                        (Just write_m)--  return (DuplexHandle filepath read_m write_m)---- | like 'mkFileHandle', except that a 'Handle' is created with two--- independent buffers, one for reading and one for writing.  Used for--- full-duplex streams, such as network sockets.-mkDuplexHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev-               -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle-mkDuplexHandle dev filepath mb_codec tr_newlines = do-  handle <- mkDuplexHandleNoFinalizer dev filepath mb_codec tr_newlines-  addHandleFinalizer handle handleFinalizer-  pure handle--ioModeToHandleType :: IOMode -> HandleType-ioModeToHandleType ReadMode      = ReadHandle-ioModeToHandleType WriteMode     = WriteHandle-ioModeToHandleType ReadWriteMode = ReadWriteHandle-ioModeToHandleType AppendMode    = AppendHandle--initBufferState :: HandleType -> BufferState-initBufferState ReadHandle = ReadBuffer-initBufferState _          = WriteBuffer--openTextEncoding-   :: Maybe TextEncoding-   -> HandleType-   -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)-   -> IO a--openTextEncoding Nothing   ha_type cont = cont Nothing Nothing-openTextEncoding (Just TextEncoding{..}) ha_type cont = do-    mb_decoder <- if isReadableHandleType ha_type then do-                     decoder <- mkTextDecoder-                     return (Just decoder)-                  else-                     return Nothing-    mb_encoder <- if isWritableHandleType ha_type then do-                     encoder <- mkTextEncoder-                     return (Just encoder)-                  else-                     return Nothing-    cont mb_encoder mb_decoder--closeTextCodecs :: Handle__ -> IO ()-closeTextCodecs Handle__{..} = do-  case haDecoder of Nothing -> return (); Just d -> Encoding.close d-  case haEncoder of Nothing -> return (); Just d -> Encoding.close d---- ------------------------------------------------------------------------------ Closing a handle---- | This function exists temporarily to avoid an unused import warning in--- `bytestring`.-hClose_impl :: Handle -> IO ()-hClose_impl h@(FileHandle _ m)     = do-  mb_exc <- hClose' h m-  hClose_maybethrow mb_exc h-hClose_impl h@(DuplexHandle _ r w) = do-  excs <- mapM (hClose' h) [r,w]-  hClose_maybethrow (listToMaybe (catMaybes excs)) h--hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()-hClose_maybethrow Nothing  h = return ()-hClose_maybethrow (Just e) h = hClose_rethrow e h--hClose_rethrow :: SomeException -> Handle -> IO ()-hClose_rethrow e h =-  case fromException e of-    Just ioe -> ioError (augmentIOError ioe "hClose" h)-    Nothing  -> throwIO e--hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)-hClose' h m = withHandle' "hClose" h m $ hClose_help---- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when--- EOF is read or an IO error occurs on a lazy stream.  The--- semi-closed Handle is then closed immediately.  We have to be--- careful with DuplexHandles though: we have to leave the closing to--- the finalizer in that case, because the write side may still be in--- use.-hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)-hClose_help handle_ =-  case haType handle_ of-      ClosedHandle -> return (handle_,Nothing)-      _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible-                    -- it is important that hClose doesn't fail and-                    -- leave the Handle open (#3128), so we catch-                    -- exceptions when flushing the buffer.-              (h_, mb_exc2) <- hClose_handle_ handle_-              return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)---trymaybe :: IO () -> IO (Maybe SomeException)-trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)--hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)-hClose_handle_ h_@Handle__{..} = do--    -- close the file descriptor, but not when this is the read-    -- side of a duplex handle.-    -- If an exception is raised by the close(), we want to continue-    -- to close the handle and release the lock if it has one, then-    -- we return the exception to the caller of hClose_help which can-    -- raise it if necessary.-    maybe_exception <--      case haOtherSide of-        Nothing -> trymaybe $ IODevice.close haDevice-        Just _  -> return Nothing--    -- free the spare buffers-    writeIORef haBuffers BufferListNil-    writeIORef haCharBuffer noCharBuffer-    writeIORef haByteBuffer noByteBuffer--    -- release our encoder/decoder-    closeTextCodecs h_--    -- we must set the fd to -1, because the finalizer is going-    -- to run eventually and try to close/unlock it.-    -- ToDo: necessary?  the handle will be marked ClosedHandle-    -- XXX GHC won't let us use record update here, hence wildcards-    return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)--{-# NOINLINE noCharBuffer #-}-noCharBuffer :: CharBuffer-noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer--{-# NOINLINE noByteBuffer #-}-noByteBuffer :: Buffer Word8-noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer---- ------------------------------------------------------------------------------ Looking ahead--hLookAhead_ :: Handle__ -> IO Char-hLookAhead_ handle_@Handle__{..} = do-    buf <- readIORef haCharBuffer--    -- fill up the read buffer if necessary-    new_buf <- if isEmptyBuffer buf-                  then readTextDevice handle_ buf-                  else return buf-    writeIORef haCharBuffer new_buf--    peekCharBuf (bufRaw buf) (bufL buf)---- ------------------------------------------------------------------------------ debugging--debugIO :: String -> IO ()--- debugIO s = traceEventIO s-debugIO s- | c_DEBUG_DUMP-    = do _ <- withCStringLen (s ++ "\n") $-                  \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)-         return ()- | otherwise = return ()---- For development, like debugIO but always on.-traceIO :: String -> IO ()-traceIO s = do-         _ <- withCStringLen (s ++ "\n") $-                  \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)-         return ()---- ------------------------------------------------------------------------------- Text input/output---- Read characters into the provided buffer.  Return when any--- characters are available; raise an exception if the end of--- file is reached.------ In uses of readTextDevice within base, the input buffer is either:---   * empty---   * or contains a single \r (when doing newline translation)------ The input character buffer must have a capacity at least 1 greater--- than the number of elements it currently contains.------ Users of this function expect that the buffer returned contains--- at least 1 more character than the input buffer.-readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer-readTextDevice h_@Handle__{..} cbuf = do-  ---  bbuf0 <- readIORef haByteBuffer--  debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++-        " bbuf=" ++ summaryBuffer bbuf0)--  bbuf1 <- if not (isEmptyBuffer bbuf0)-              then return bbuf0-              else do-                   debugIO $ "readBuf at " ++ show (bufferOffset bbuf0)-                   (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0-                   debugIO $ "readBuf after " ++ show (bufferOffset bbuf1)-                   if r == 0 then ioe_EOF else do  -- raise EOF-                   return bbuf1--  debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)--  (bbuf2,cbuf') <--      case haDecoder of-          Nothing      -> do-               writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf1)-               latin1_decode bbuf1 cbuf-          Just decoder -> do-               state <- getState decoder-               writeIORef haLastDecode (state, bbuf1)-               (streamEncode decoder) bbuf1 cbuf--  debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++-        " bbuf=" ++ summaryBuffer bbuf2)--  -- We can't return from readTextDevice without reading at least a single extra character,-  -- so check that we have managed to achieve that-  writeIORef haByteBuffer bbuf2-  if bufR cbuf' == bufR cbuf-     -- we need more bytes to make a Char. NB: bbuf2 may be empty (even though bbuf1 wasn't) when we-     -- are using an encoding that can skip bytes without outputting characters, such as UTF8//IGNORE-     then readTextDevice' h_ bbuf2 cbuf-     else return cbuf'---- we have an incomplete byte sequence at the end of the buffer: try to--- read more bytes.-readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer-readTextDevice' h_@Handle__{..} bbuf0 cbuf0 = do-  ---  -- copy the partial sequence to the beginning of the buffer, so we have-  -- room to read more bytes.-  bbuf1 <- slideContents bbuf0--  -- readTextDevice only calls us if we got some bytes but not some characters.-  -- This can't occur if haDecoder is Nothing because latin1_decode accepts all bytes.-  let Just decoder = haDecoder--  (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1-  if r == 0-   then do-     -- bbuf2 can be empty here when we encounter an invalid byte sequence at the end of the input-     -- with a //IGNORE codec which consumes bytes without outputting characters-     if isEmptyBuffer bbuf2 then ioe_EOF else do-     (bbuf3, cbuf1) <- recover decoder bbuf2 cbuf0-     debugIO ("readTextDevice' after recovery: bbuf=" ++ summaryBuffer bbuf3 ++ ", cbuf=" ++ summaryBuffer cbuf1)-     writeIORef haByteBuffer bbuf3-     -- We should recursively invoke readTextDevice after recovery,-     -- if recovery did not add at least one new character to the buffer:-     --  1. If we were using IgnoreCodingFailure it might be the case that-     --     cbuf1 is the same length as cbuf0 and we need to raise ioe_EOF-     --  2. If we were using TransliterateCodingFailure we might have *mutated*-     --     the byte buffer without changing the pointers into either buffer.-     --     We need to try and decode it again - it might just go through this time.-     if bufR cbuf1 == bufR cbuf0-      then readTextDevice h_ cbuf1-      else return cbuf1-   else do-    debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)--    (bbuf3,cbuf1) <- do-       state <- getState decoder-       writeIORef haLastDecode (state, bbuf2)-       (streamEncode decoder) bbuf2 cbuf0--    debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf1 ++-          " bbuf=" ++ summaryBuffer bbuf3)--    writeIORef haByteBuffer bbuf3-    if bufR cbuf0 == bufR cbuf1-       then readTextDevice' h_ bbuf3 cbuf1-       else return cbuf1---- Read characters into the provided buffer.  Do not block;--- return zero characters instead.  Raises an exception on end-of-file.-readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer-readTextDeviceNonBlocking h_@Handle__{..} cbuf = do-  ---  bbuf0 <- readIORef haByteBuffer-  when (isEmptyBuffer bbuf0) $ do-     (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0-     if isNothing r then ioe_EOF else do  -- raise EOF-     writeIORef haByteBuffer bbuf1--  decodeByteBuf h_ cbuf---- Decode bytes from the byte buffer into the supplied CharBuffer.-decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer-decodeByteBuf h_@Handle__{..} cbuf = do-  ---  bbuf0 <- readIORef haByteBuffer--  (bbuf2,cbuf') <--      case haDecoder of-          Nothing      -> do-               writeIORef haLastDecode (errorWithoutStackTrace "codec_state", bbuf0)-               latin1_decode bbuf0 cbuf-          Just decoder -> do-               state <- getState decoder-               writeIORef haLastDecode (state, bbuf0)-               (streamEncode decoder) bbuf0 cbuf--  writeIORef haByteBuffer bbuf2-  return cbuf'-
− GHC/IO/Handle/Lock.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO.Handle.Lock (-    FileLockingNotSupported(..)-  , LockMode(..)-  , hLock-  , hTryLock-  , hUnlock-  ) where---#include "HsBaseConfig.h"--import Data.Functor (void)-import GHC.Base-import GHC.IO.Handle.Lock.Common (LockMode(..), FileLockingNotSupported(..))-import GHC.IO.Handle.Types (Handle)--#if defined(mingw32_HOST_OS)-import GHC.IO.Handle.Lock.Windows-#elif HAVE_OFD_LOCKING-import GHC.IO.Handle.Lock.LinuxOFD-#elif HAVE_FLOCK-import GHC.IO.Handle.Lock.Flock-#else-import GHC.IO.Handle.Lock.NoOp-#endif---- | If a 'Handle' references a file descriptor, attempt to lock contents of the--- underlying file in appropriate mode. If the file is already locked in--- incompatible mode, this function blocks until the lock is established. The--- lock is automatically released upon closing a 'Handle'.------ Things to be aware of:------ 1) This function may block inside a C call. If it does, in order to be able--- to interrupt it with asynchronous exceptions and/or for other threads to--- continue working, you MUST use threaded version of the runtime system.------ 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,--- hence all of their caveats also apply here.------ 3) On non-Windows platforms that don't support 'flock' (e.g. Solaris) this--- function throws 'FileLockingNotImplemented'. We deliberately choose to not--- provide fcntl based locking instead because of its broken semantics.------ @since 4.10.0.0-hLock :: Handle -> LockMode -> IO ()-hLock h mode = void $ lockImpl h "hLock" mode True---- | Non-blocking version of 'hLock'.------ Returns 'True' if taking the lock was successful and 'False' otherwise.------ @since 4.10.0.0-hTryLock :: Handle -> LockMode -> IO Bool-hTryLock h mode = lockImpl h "hTryLock" mode False---- | Release a lock taken with 'hLock' or 'hTryLock'.------ @since 4.11.0.0-hUnlock :: Handle -> IO ()-hUnlock = unlockImpl-------------------------------------------
− GHC/IO/Handle/Lock/Common.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}---- | Things common to all file locking implementations.-module GHC.IO.Handle.Lock.Common-  ( FileLockingNotSupported(..)-  , LockMode(..)-  ) where--import GHC.Exception-import GHC.Show---- | Exception thrown by 'hLock' on non-Windows platforms that don't support--- 'flock'.-data FileLockingNotSupported = FileLockingNotSupported-  deriving Show -- ^ @since 4.10.0.0---- ^ @since 4.10.0.0-instance Exception FileLockingNotSupported---- | Indicates a mode in which a file should be locked.-data LockMode = SharedLock | ExclusiveLock
− GHC/IO/Handle/Lock/Flock.hsc 
@@ -1,53 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | File locking via POSIX @flock@.-module GHC.IO.Handle.Lock.Flock where--#include "HsBaseConfig.h"--#if !HAVE_FLOCK-import GHC.Base () -- Make implicit dependency known to build system-#else--#include <sys/file.h>--import Data.Bits-import Data.Function-import Foreign.C.Error-import Foreign.C.Types-import GHC.Base-import GHC.IO.Exception-import GHC.IO.FD-import GHC.IO.Handle.FD-import GHC.IO.Handle.Lock.Common-import GHC.IO.Handle.Types (Handle)--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl h ctx mode block = do-  FD{fdFD = fd} <- handleToFd h-  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})-  fix $ \retry -> c_flock fd flags >>= \case-    0 -> return True-    _ -> getErrno >>= \errno -> if-      | not block-      , errno == eAGAIN || errno == eACCES -> return False-      | errno == eINTR -> retry-      | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing-  where-    cmode = case mode of-      SharedLock    -> #{const LOCK_SH}-      ExclusiveLock -> #{const LOCK_EX}--unlockImpl :: Handle -> IO ()-unlockImpl h = do-  FD{fdFD = fd} <- handleToFd h-  throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN}--foreign import ccall interruptible "flock"-  c_flock :: CInt -> CInt -> IO CInt--#endif
− GHC/IO/Handle/Lock/LinuxOFD.hsc 
@@ -1,107 +0,0 @@-{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | File locking via the Linux open-fd locking mechanism.-module GHC.IO.Handle.Lock.LinuxOFD where--#include "HsBaseConfig.h"--#if !HAVE_OFD_LOCKING-import GHC.Base () -- Make implicit dependency known to build system-#else---- Not only is this a good idea but it also works around #17950.-#define _FILE_OFFSET_BITS 64--#include <unistd.h>-#include <fcntl.h>--import Data.Function-import Data.Functor-import Foreign.C.Error-import Foreign.C.Types-import Foreign.Marshal.Utils-import Foreign.Storable-import GHC.Base-import GHC.IO.Exception-import GHC.IO.FD-import GHC.IO.Handle.FD-import GHC.IO.Handle.Lock.Common-import GHC.IO.Handle.Types (Handle)-import GHC.Ptr-import System.Posix.Types (COff, CPid)---- Linux open file descriptor locking.------ We prefer this over BSD locking (e.g. flock) since the latter appears to--- break in some NFS configurations. Note that we intentionally do not try to--- use ordinary POSIX file locking due to its peculiar semantics under--- multi-threaded environments.--foreign import capi interruptible "fcntl.h fcntl"-  c_fcntl :: CInt -> CInt -> Ptr FLock -> IO CInt--data FLock  = FLock { l_type   :: CShort-                    , l_whence :: CShort-                    , l_start  :: COff-                    , l_len    :: COff-                    , l_pid    :: CPid-                    }--instance Storable FLock where-    sizeOf _ = #{size struct flock}-    alignment _ = #{alignment struct flock}-    poke ptr x = do-        fillBytes ptr 0 (sizeOf x)-        #{poke struct flock, l_type}   ptr (l_type x)-        #{poke struct flock, l_whence} ptr (l_whence x)-        #{poke struct flock, l_start}  ptr (l_start x)-        #{poke struct flock, l_len}    ptr (l_len x)-        #{poke struct flock, l_pid}    ptr (l_pid x)-    peek ptr =-        FLock <$> #{peek struct flock, l_type}   ptr-              <*> #{peek struct flock, l_whence} ptr-              <*> #{peek struct flock, l_start}  ptr-              <*> #{peek struct flock, l_len}    ptr-              <*> #{peek struct flock, l_pid}    ptr--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl h ctx mode block = do-  FD{fdFD = fd} <- handleToFd h-  with flock $ \flock_ptr -> fix $ \retry -> do-      ret <- c_fcntl fd mode' flock_ptr-      case ret of-        0 -> return True-        _ -> getErrno >>= \errno -> if-          | not block && errno == eWOULDBLOCK -> return False-          | errno == eINTR -> retry-          | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing-  where-    flock = FLock { l_type = case mode of-                               SharedLock -> #{const F_RDLCK}-                               ExclusiveLock -> #{const F_WRLCK}-                  , l_whence = #{const SEEK_SET}-                  , l_start = 0-                  , l_len = 0-                  , l_pid = 0-                  }-    mode'-      | block     = #{const F_OFD_SETLKW}-      | otherwise = #{const F_OFD_SETLK}--unlockImpl :: Handle -> IO ()-unlockImpl h = do-  FD{fdFD = fd} <- handleToFd h-  let flock = FLock { l_type = #{const F_UNLCK}-                    , l_whence = #{const SEEK_SET}-                    , l_start = 0-                    , l_len = 0-                    , l_pid = 0-                    }-  throwErrnoIfMinus1_ "hUnlock"-      $ with flock $ c_fcntl fd #{const F_OFD_SETLK}--#endif
− GHC/IO/Handle/Lock/NoOp.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.IO.Handle.Lock.NoOp where--import GHC.Base-import GHC.IO (throwIO)-import GHC.IO.Handle.Lock.Common-import GHC.IO.Handle.Types (Handle)---- | No-op implementation.-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl _ _ _ _ = throwIO FileLockingNotSupported---- | No-op implementation.-unlockImpl :: Handle -> IO ()-unlockImpl _ = throwIO FileLockingNotSupported
− GHC/IO/Handle/Lock/Windows.hsc 
@@ -1,138 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}---- | File locking for Windows.-module GHC.IO.Handle.Lock.Windows where--#include "HsBaseConfig.h"--#if !defined(mingw32_HOST_OS)-import GHC.Base () -- Make implicit dependency known to build system-#else--##include <windows_cconv.h>-#include <windows.h>--import Data.Bits-import Data.Function-import GHC.IO.Handle.Windows (handleToHANDLE)-import Foreign.C.Error-import Foreign.C.Types-import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils-import GHC.Base-import qualified GHC.Event.Windows as Mgr-import GHC.Event.Windows (LPOVERLAPPED, withOverlapped)-import GHC.IO.FD-import GHC.IO.Handle.FD-import GHC.IO.Handle.Types (Handle)-import GHC.IO.Handle.Lock.Common (LockMode(..))-import GHC.IO.SubSystem-import GHC.Windows--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl = lockImplPOSIX <!> lockImplWinIO--lockImplWinIO :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImplWinIO h ctx mode block = do-  wh      <- handleToHANDLE h-  fix $ \retry ->-          do retcode <- Mgr.withException ctx $-                          withOverlapped ctx wh 0 (startCB wh) completionCB-             case () of-              _ | retcode == #{const ERROR_OPERATION_ABORTED} -> retry-                | retcode == #{const ERROR_SUCCESS}           -> return True-                | retcode == #{const ERROR_LOCK_VIOLATION} && not block-                    -> return False-                | otherwise -> failWith ctx retcode-    where-      cmode = case mode of-                SharedLock    -> 0-                ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}-      flags = if block-                 then cmode-                 else cmode .|. #{const LOCKFILE_FAIL_IMMEDIATELY}--      startCB wh lpOverlapped = do-        ret <- c_LockFileEx wh flags 0 #{const INFINITE} #{const INFINITE}-                            lpOverlapped-        return $ Mgr.CbNone ret--      completionCB err _dwBytes-        | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess 0-        | otherwise                     = Mgr.ioFailed err--lockImplPOSIX :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImplPOSIX h ctx mode block = do-  FD{fdFD = fd} <- handleToFd h-  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd-  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do-    fillBytes ovrlpd 0 sizeof_OVERLAPPED-    let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})-    -- We want to lock the whole file without looking up its size to be-    -- consistent with what flock does. According to documentation of LockFileEx-    -- "locking a region that goes beyond the current end-of-file position is-    -- not an error", hence we pass maximum value as the number of bytes to-    -- lock.-    fix $ \retry -> c_LockFileEx wh flags 0 #{const INFINITE} #{const INFINITE}-                                 ovrlpd >>= \case-      True  -> return True-      False -> getLastError >>= \err -> if-        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False-        | err == #{const ERROR_OPERATION_ABORTED}           -> retry-        | otherwise                                         -> failWith ctx err-  where-    sizeof_OVERLAPPED = #{size OVERLAPPED}--    cmode = case mode of-      SharedLock    -> 0-      ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}--unlockImpl :: Handle -> IO ()-unlockImpl = unlockImplPOSIX <!> unlockImplWinIO--unlockImplWinIO :: Handle -> IO ()-unlockImplWinIO h = do-  wh <- handleToHANDLE h-  _ <- Mgr.withException "unlockImpl" $-          withOverlapped "unlockImpl" wh 0 (startCB wh) completionCB-  return ()-    where-      startCB wh lpOverlapped = do-        ret <- c_UnlockFileEx wh 0 #{const INFINITE} #{const INFINITE}-                              lpOverlapped-        return $ Mgr.CbNone ret--      completionCB err _dwBytes-        | err == #{const ERROR_SUCCESS} = Mgr.ioSuccess 0-        | otherwise                     = Mgr.ioFailed err--unlockImplPOSIX :: Handle -> IO ()-unlockImplPOSIX h = do-  FD{fdFD = fd} <- handleToFd h-  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd-  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do-    fillBytes ovrlpd 0 sizeof_OVERLAPPED-    c_UnlockFileEx wh 0 #{const INFINITE} #{const INFINITE} ovrlpd >>= \case-      True  -> return ()-      False -> getLastError >>= failWith "hUnlock"-  where-    sizeof_OVERLAPPED = #{size OVERLAPPED}---- https://msdn.microsoft.com/en-us/library/aa297958.aspx-foreign import ccall unsafe "_get_osfhandle"-  c_get_osfhandle :: CInt -> IO HANDLE---- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx-foreign import WINDOWS_CCONV interruptible "LockFileEx"-  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED-               -> IO BOOL---- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx-foreign import WINDOWS_CCONV interruptible "UnlockFileEx"-  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL--#endif
− GHC/IO/Handle/Text.hs 
@@ -1,1153 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , RecordWildCards-           , BangPatterns-           , NondecreasingIndentation-           , MagicHash-  #-}-{-# OPTIONS_GHC -Wno-unused-matches #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Text--- Copyright   :  (c) The University of Glasgow, 1992-2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ String I\/O functions-----------------------------------------------------------------------------------module GHC.IO.Handle.Text (-        hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,-        commitBuffer',       -- hack, see below-        hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,-        memcpy, hPutStrLn, hGetContents',-    ) where--import GHC.IO-import GHC.IO.Buffer-import qualified GHC.IO.BufferedIO as Buffered-import GHC.IO.Exception-import GHC.Exception-import GHC.IO.Handle.Types-import GHC.IO.Handle.Internals-import qualified GHC.IO.Device as IODevice-import qualified GHC.IO.Device as RawIO--import Foreign-import Foreign.C--import qualified Control.Exception as Exception-import System.IO.Error-import Data.Either (Either(..))-import Data.Maybe--import GHC.IORef-import GHC.Base-import GHC.Real-import GHC.Num-import GHC.Show-import GHC.List---- ------------------------------------------------------------------------------ Simple input operations---- If hWaitForInput finds anything in the Handle's buffer, it--- immediately returns.  If not, it tries to read from the underlying--- OS handle. Notice that for buffered Handles connected to terminals--- this means waiting until a complete line is available.---- | Computation 'hWaitForInput' @hdl t@--- waits until input is available on handle @hdl@.--- It returns 'True' as soon as input is available on @hdl@,--- or 'False' if no input is available within @t@ milliseconds.  Note that--- 'hWaitForInput' waits until one or more full /characters/ are available,--- which means that it needs to do decoding, and hence may fail--- with a decoding error.------ If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.------ This operation may fail with:------  * 'isEOFError' if the end of file has been reached.------  * a decoding error, if the input begins with an invalid byte sequence---    in this Handle's encoding.------ NOTE for GHC users: unless you use the @-threaded@ flag,--- @hWaitForInput hdl t@ where @t >= 0@ will block all other Haskell--- threads for the duration of the call.  It behaves like a--- @safe@ foreign call in this respect.-----hWaitForInput :: Handle -> Int -> IO Bool-hWaitForInput h msecs =-  wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do-  cbuf <- readIORef haCharBuffer--  if not (isEmptyBuffer cbuf) then return True else do--  if msecs < 0-        then do cbuf' <- readTextDevice handle_ cbuf-                writeIORef haCharBuffer cbuf'-                return True-        else do-               -- there might be bytes in the byte buffer waiting to be decoded-               cbuf' <- decodeByteBuf handle_ cbuf-               writeIORef haCharBuffer cbuf'--               if not (isEmptyBuffer cbuf') then return True else do--                r <- IODevice.ready haDevice False{-read-} msecs-                if r then do -- Call hLookAhead' to throw an EOF-                             -- exception if appropriate-                             _ <- hLookAhead_ handle_-                             return True-                     else return False-                -- XXX we should only return when there are full characters-                -- not when there are only bytes.  That would mean looping-                -- and re-running IODevice.ready if we don't have any full-                -- characters; but we don't know how long we've waited-                -- so far.---- ------------------------------------------------------------------------------ hGetChar---- | Computation 'hGetChar' @hdl@ reads a character from the file or--- channel managed by @hdl@, blocking until a character is available.------ This operation may fail with:------  * 'isEOFError' if the end of file has been reached.--hGetChar :: Handle -> IO Char-hGetChar handle =-  wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do--  -- buffering mode makes no difference: we just read whatever is available-  -- from the device (blocking only if there is nothing available), and then-  -- return the first character.-  -- See [note Buffered Reading] in GHC.IO.Handle.Types-  buf0 <- readIORef haCharBuffer--  buf1 <- if isEmptyBuffer buf0-             then readTextDevice handle_ buf0-             else return buf0--  (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)-  let buf2 = bufferAdjustL i buf1--  if haInputNL == CRLF && c1 == '\r'-     then do-            mbuf3 <- if isEmptyBuffer buf2-                      then maybeFillReadBuffer handle_ buf2-                      else return (Just buf2)--            case mbuf3 of-               -- EOF, so just return the '\r' we have-               Nothing -> do-                  writeIORef haCharBuffer buf2-                  return '\r'-               Just buf3 -> do-                  (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)-                  if c2 == '\n'-                     then do-                       writeIORef haCharBuffer (bufferAdjustL i2 buf3)-                       return '\n'-                     else do-                       -- not a \r\n sequence, so just return the \r-                       writeIORef haCharBuffer buf3-                       return '\r'-     else do-            writeIORef haCharBuffer buf2-            return c1---- ------------------------------------------------------------------------------ hGetLine---- | Computation 'hGetLine' @hdl@ reads a line from the file or--- channel managed by @hdl@.------ This operation may fail with:------  * 'isEOFError' if the end of file is encountered when reading---    the /first/ character of the line.------ If 'hGetLine' encounters end-of-file at any other point while reading--- in a line, it is treated as a line terminator and the (partial)--- line is returned.--hGetLine :: Handle -> IO String-hGetLine h =-  wantReadableHandle_ "hGetLine" h $ \ handle_ ->-    hGetLineBuffered handle_--hGetLineBuffered :: Handle__ -> IO String-hGetLineBuffered handle_@Handle__{..} = do-  buf <- readIORef haCharBuffer-  hGetLineBufferedLoop handle_ buf []--hGetLineBufferedLoop :: Handle__-                     -> CharBuffer -> [String]-                     -> IO String-hGetLineBufferedLoop handle_@Handle__{..}-        buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =-  let-        -- find the end-of-line character, if there is one-        loop raw r-           | r == w = return (False, w)-           | otherwise =  do-                (c,r') <- readCharBuf raw r-                if c == '\n'-                   then return (True, r) -- NB. not r': don't include the '\n'-                   else loop raw r'-  in do-  (eol, off) <- loop raw0 r0--  debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)--  (xs,r') <- if haInputNL == CRLF-                then unpack_nl raw0 r0 off ""-                else do xs <- unpack raw0 r0 off ""-                        return (xs,off)--  -- if eol == True, then off is the offset of the '\n'-  -- otherwise off == w and the buffer is now empty.-  if eol -- r' == off-        then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)-                return (concat (reverse (xs:xss)))-        else do-             let buf1 = bufferAdjustL r' buf-             maybe_buf <- maybeFillReadBuffer handle_ buf1-             case maybe_buf of-                -- Nothing indicates we caught an EOF, and we may have a-                -- partial line to return.-                Nothing -> do-                     -- we reached EOF.  There might be a lone \r left-                     -- in the buffer, so check for that and-                     -- append it to the line if necessary.-                     ---                     let pre = if not (isEmptyBuffer buf1) then "\r" else ""-                     writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }-                     let str = concat (reverse (pre:xs:xss))-                     if not (null str)-                        then return str-                        else ioe_EOF-                Just new_buf ->-                     hGetLineBufferedLoop handle_ new_buf (xs:xss)--maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)-maybeFillReadBuffer handle_ buf-  = catchException-     (do buf' <- getSomeCharacters handle_ buf-         return (Just buf')-     )-     (\e -> do if isEOFError e-                  then return Nothing-                  else ioError e)---- See GHC.IO.Buffer-#define CHARBUF_UTF32--- #define CHARBUF_UTF16---- NB. performance-critical code: eyeball the Core.-unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]-unpack !buf !r !w acc0- | r == w    = return acc0- | otherwise =-  withRawBuffer buf $ \pbuf ->-    let-        unpackRB acc !i-         | i < r  = return acc-         | otherwise = do-              -- Here, we are rather careful to only put an *evaluated* character-              -- in the output string. Due to pointer tagging, this allows the consumer-              -- to avoid ping-ponging between the actual consumer code and the thunk code-#if defined(CHARBUF_UTF16)-              -- reverse-order decoding of UTF-16-              c2 <- peekElemOff pbuf i-              if (c2 < 0xdc00 || c2 > 0xdffff)-                 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)-                 else do c1 <- peekElemOff pbuf (i-1)-                         let c = (fromIntegral c1 - 0xd800) * 0x400 +-                                 (fromIntegral c2 - 0xdc00) + 0x10000-                         case desurrogatifyRoundtripCharacter (unsafeChr c) of-                           { C# c# -> unpackRB (C# c# : acc) (i-2) }-#else-              c <- peekElemOff pbuf i-              unpackRB (c : acc) (i-1)-#endif-     in-     unpackRB acc0 (w-1)---- NB. performance-critical code: eyeball the Core.-unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)-unpack_nl !buf !r !w acc0- | r == w    =  return (acc0, 0)- | otherwise =-  withRawBuffer buf $ \pbuf ->-    let-        unpackRB acc !i-         | i < r  = return acc-         | otherwise = do-              c <- peekElemOff pbuf i-              if (c == '\n' && i > r)-                 then do-                   c1 <- peekElemOff pbuf (i-1)-                   if (c1 == '\r')-                      then unpackRB ('\n':acc) (i-2)-                      else unpackRB ('\n':acc) (i-1)-                 else-                   unpackRB (c : acc) (i-1)-     in do-     c <- peekElemOff pbuf (w-1)-     if (c == '\r')-        then do-                -- If the last char is a '\r', we need to know whether or-                -- not it is followed by a '\n', so leave it in the buffer-                -- for now and just unpack the rest.-                str <- unpackRB acc0 (w-2)-                return (str, w-1)-        else do-                str <- unpackRB acc0 (w-1)-                return (str, w)---- Note [#5536]------ We originally had------    let c' = desurrogatifyRoundtripCharacter c in---    c' `seq` unpackRB (c':acc) (i-1)------ but this resulted in Core like------    case (case x <# y of True -> C# e1; False -> C# e2) of c---      C# _ -> unpackRB (c:acc) (i-1)------ which compiles into a continuation for the outer case, with each--- branch of the inner case building a C# and then jumping to the--- continuation.  We'd rather not have this extra jump, which makes--- quite a difference to performance (see #5536) It turns out that--- matching on the C# directly causes GHC to do the case-of-case,--- giving much straighter code.---- -------------------------------------------------------------------------------- hGetContents---- hGetContents on a DuplexHandle only affects the read side: you can--- carry on writing to it afterwards.---- | Computation 'hGetContents' @hdl@ returns the list of characters--- corresponding to the unread portion of the channel or file managed--- by @hdl@, which is put into an intermediate state, /semi-closed/.--- In this state, @hdl@ is effectively closed,--- but items are read from @hdl@ on demand and accumulated in a special--- list returned by 'hGetContents' @hdl@.------ Any operation that fails because a handle is closed,--- also fails if a handle is semi-closed.  The only exception is--- 'System.IO.hClose'.  A semi-closed handle becomes closed:------  * if 'System.IO.hClose' is applied to it;------  * if an I\/O error occurs when reading an item from the handle;------  * or once the entire contents of the handle has been read.------ Once a semi-closed handle becomes closed, the contents of the--- associated list becomes fixed.  The contents of this final list is--- only partially specified: it will contain at least all the items of--- the stream that were evaluated prior to the handle becoming closed.------ Any I\/O errors encountered while a handle is semi-closed are simply--- discarded.------ This operation may fail with:------  * 'isEOFError' if the end of file has been reached.--hGetContents :: Handle -> IO String-hGetContents handle =-   wantReadableHandle "hGetContents" handle $ \handle_ -> do-      xs <- lazyRead handle-      return (handle_{ haType=SemiClosedHandle}, xs )---- Note that someone may close the semi-closed handle (or change its--- buffering), so each time these lazy read functions are pulled on,--- they have to check whether the handle has indeed been closed.--lazyRead :: Handle -> IO String-lazyRead handle =-   unsafeInterleaveIO $-        withHandle "hGetContents" handle $ \ handle_ -> do-        case haType handle_ of-          SemiClosedHandle -> lazyReadBuffered handle handle_-          ClosedHandle-            -> ioException-                  (IOError (Just handle) IllegalOperation "hGetContents"-                        "delayed read on closed handle" Nothing Nothing)-          _ -> ioException-                  (IOError (Just handle) IllegalOperation "hGetContents"-                        "illegal handle type" Nothing Nothing)--lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])-lazyReadBuffered h handle_@Handle__{..} = do-   buf <- readIORef haCharBuffer-   Exception.catch-        (do-            buf'@Buffer{..} <- getSomeCharacters handle_ buf-            lazy_rest <- lazyRead h-            (s,r) <- if haInputNL == CRLF-                         then unpack_nl bufRaw bufL bufR lazy_rest-                         else do s <- unpack bufRaw bufL bufR lazy_rest-                                 return (s,bufR)-            writeIORef haCharBuffer (bufferAdjustL r buf')-            return (handle_, s)-        )-        (\e -> do (handle_', _) <- hClose_help handle_-                  debugIO ("hGetContents caught: " ++ show e)-                  -- We might have a \r cached in CRLF mode.  So we-                  -- need to check for that and return it:-                  let r = if isEOFError e-                             then if not (isEmptyBuffer buf)-                                     then "\r"-                                     else ""-                             else-                                  throw (augmentIOError e "hGetContents" h)--                  return (handle_', r)-        )---- ensure we have some characters in the buffer-getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer-getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =-  case bufferElems buf of--    -- buffer empty: read some more-    0 -> readTextDevice handle_ buf--    -- if the buffer has a single '\r' in it and we're doing newline-    -- translation: read some more-    1 | haInputNL == CRLF -> do-      (c,_) <- readCharBuf bufRaw bufL-      if c == '\r'-      then do-        -- shuffle the '\r' to the beginning.  This is only safe-        -- if we're about to call readTextDevice, otherwise it-        -- would mess up flushCharBuffer.-        -- See [note Buffer Flushing], GHC.IO.Handle.Types-        _ <- writeCharBuf bufRaw 0 '\r'-        let buf' = buf{ bufL=0, bufR=1 }-        readTextDevice handle_ buf'-      else-        return buf--    -- buffer has some chars in it already: just return it-    _otherwise ->-      return buf---- -------------------------------------------------------------------------------- hGetContents'---- We read everything into a list of CharBuffer chunks, and convert it lazily--- to a string, which minimizes memory usage.--- In the worst case, space usage is at most that of the complete String,--- as the chunks can be garbage collected progressively.--- For streaming consumers, space usage is at most that of the list of chunks.---- | The 'hGetContents'' operation reads all input on the given handle--- before returning it as a 'String' and closing the handle.------ @since 4.15.0.0--hGetContents' :: Handle -> IO String-hGetContents' handle = do-    es <- wantReadableHandle "hGetContents'" handle (strictRead handle)-    case es of-      Right s -> return s-      Left e ->-          case fromException e of-            Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle)-            Nothing -> throwIO e--strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String)-strictRead h handle_@Handle__{..} = do-    cbuf <- readIORef haCharBuffer-    cbufs <- strictReadLoop' handle_ [] cbuf-    (handle_', me) <- hClose_help handle_-    case me of-      Just e -> return (handle_', Left e)-      Nothing -> do-        s <- lazyBuffersToString haInputNL cbufs ""-        return (handle_', Right s)--strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer]-strictReadLoop handle_ cbufs cbuf0 = do-    mcbuf <- Exception.catch-        (do r <- readTextDevice handle_ cbuf0-            return (Just r))-        (\e -> if isEOFError e-                  then return Nothing-                  else throw e)-    case mcbuf of-      Nothing -> return (cbuf0 : cbufs)-      Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1---- If 'cbuf' is full, allocate a new buffer.-strictReadLoop' :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer]-strictReadLoop' handle_ cbufs cbuf-    | isFullCharBuffer cbuf = do-        cbuf' <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE ReadBuffer-        strictReadLoop handle_ (cbuf : cbufs) cbuf'-    | otherwise = strictReadLoop handle_ cbufs cbuf---- Lazily convert a list of buffers to a String. The buffers are--- in reverse order: the first buffer is the end of the String.-lazyBuffersToString :: Newline -> [CharBuffer] -> String -> IO String-lazyBuffersToString LF = loop where-    loop [] s = return s-    loop (Buffer{..} : cbufs) s = do-        s' <- unsafeInterleaveIO (unpack bufRaw bufL bufR s)-        loop cbufs s'-lazyBuffersToString CRLF = loop '\0' where-    loop before [] s = return s-    loop before (Buffer{..} : cbufs) s-        | bufL == bufR = loop before cbufs s  -- skip empty buffers-        | otherwise = do-            -- When a CRLF is broken across two buffers, we already have a newline-            -- from decoding the LF, so we ignore the CR in the current buffer.-            s1 <- if before == '\n'-                     then return s-                     else do-                       -- We restore trailing CR not followed by LF.-                       c <- peekCharBuf bufRaw (bufR - 1)-                       if c == '\r'-                          then return ('\r' : s)-                          else return s-            s2 <- unsafeInterleaveIO (do-                (s2, _) <- unpack_nl bufRaw bufL bufR s1-                return s2)-            c0 <- peekCharBuf bufRaw bufL-            loop c0 cbufs s2---- ------------------------------------------------------------------------------ hPutChar---- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the--- file or channel managed by @hdl@.  Characters may be buffered if--- buffering is enabled for @hdl@.------ This operation may fail with:------  * 'isFullError' if the device is full; or------  * 'isPermissionError' if another system resource limit would be exceeded.--hPutChar :: Handle -> Char -> IO ()-hPutChar handle c = do-    c `seq` return ()-    wantWritableHandle "hPutChar" handle $ \ handle_  ->-      hPutcBuffered handle_ c--hPutcBuffered :: Handle__ -> Char -> IO ()-hPutcBuffered handle_@Handle__{..} c = do-  buf <- readIORef haCharBuffer-  if c == '\n'-     then do buf1 <- if haOutputNL == CRLF-                     then do-                       buf1 <- putc buf '\r'-                       putc buf1 '\n'-                     else-                       putc buf '\n'-             writeCharBuffer handle_ buf1-             when isLine $ flushByteWriteBuffer handle_-      else do-          buf1 <- putc buf c-          writeCharBuffer handle_ buf1-          return ()-  where-    isLine = case haBufferMode of-                LineBuffering -> True-                _             -> False--    putc buf@Buffer{ bufRaw=raw, bufR=w } c' = do-       debugIO ("putc: " ++ summaryBuffer buf)-       w'  <- writeCharBuf raw w c'-       return buf{ bufR = w' }---- ------------------------------------------------------------------------------ hPutStr---- We go to some trouble to avoid keeping the handle locked while we're--- evaluating the string argument to hPutStr, in case doing so triggers another--- I/O operation on the same handle which would lead to deadlock.  The classic--- case is------              putStr (trace "hello" "world")------ so the basic scheme is this:------      * copy the string into a fresh buffer,---      * "commit" the buffer to the handle.------ Committing may involve simply copying the contents of the new--- buffer into the handle's buffer, flushing one or both buffers, or--- maybe just swapping the buffers over (if the handle's buffer was--- empty).  See commitBuffer below.---- | Computation 'hPutStr' @hdl s@ writes the string--- @s@ to the file or channel managed by @hdl@.------ This operation may fail with:------  * 'isFullError' if the device is full; or------  * 'isPermissionError' if another system resource limit would be exceeded.--hPutStr :: Handle -> String -> IO ()-hPutStr handle str = hPutStr' handle str False---- | The same as 'hPutStr', but adds a newline character.-hPutStrLn :: Handle -> String -> IO ()-hPutStrLn handle str = hPutStr' handle str True-  -- An optimisation: we treat hPutStrLn specially, to avoid the-  -- overhead of a single putChar '\n', which is quite high now that we-  -- have to encode eagerly.--{-# NOINLINE hPutStr' #-}-hPutStr' :: Handle -> String -> Bool -> IO ()-hPutStr' handle str add_nl =-  do-    (buffer_mode, nl) <--         wantWritableHandle "hPutStr" handle $ \h_ -> do-                       bmode <- getSpareBuffer h_-                       return (bmode, haOutputNL h_)--    case buffer_mode of-       (NoBuffering, _) -> do-            hPutChars handle str        -- v. slow, but we don't care-            when add_nl $ hPutChar handle '\n'-       (LineBuffering, buf) ->-            writeBlocks handle True  add_nl nl buf str-       (BlockBuffering _, buf) ->-            writeBlocks handle False add_nl nl buf str--hPutChars :: Handle -> [Char] -> IO ()-hPutChars _      [] = return ()-hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs---- Buffer offset is always zero.-getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)-getSpareBuffer Handle__{haCharBuffer=ref, haBuffers=spare_ref, haBufferMode=mode} =-   case mode of-     NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!")-     _ -> do-          bufs <- readIORef spare_ref-          buf  <- readIORef ref-          case bufs of-            BufferListCons b rest -> do-                writeIORef spare_ref rest-                return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)-            BufferListNil -> do-                new_buf <- newCharBuffer (bufSize buf) WriteBuffer-                return (mode, new_buf)----- NB. performance-critical code: eyeball the Core.-writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()-writeBlocks hdl line_buffered add_nl nl-            buf@Buffer{ bufRaw=raw, bufSize=len } s =-  let-   shoveString :: Int -> [Char] -> [Char] -> IO ()-   shoveString !n [] [] =-        commitBuffer hdl raw len n False{-no flush-} True{-release-}-   shoveString !n [] rest =-        shoveString n rest []-   shoveString !n (c:cs) rest-     -- n+1 so we have enough room to write '\r\n' if necessary-     | n + 1 >= len = do-        commitBuffer hdl raw len n False{-flush-} False-        shoveString 0 (c:cs) rest-     | c == '\n'  =  do-        n' <- if nl == CRLF-              then do-                n1 <- writeCharBuf raw n  '\r'-                writeCharBuf raw n1 '\n'-              else-                writeCharBuf raw n c-        if line_buffered-        then do-          -- end of line, so write and flush-          commitBuffer hdl raw len n' True{-flush-} False-          shoveString 0 cs rest-        else-          shoveString n' cs rest-     | otherwise = do-        n' <- writeCharBuf raw n c-        shoveString n' cs rest-  in-  shoveString 0 s (if add_nl then "\n" else "")---- -------------------------------------------------------------------------------- commitBuffer handle buf sz count flush release------ Write the contents of the buffer 'buf' ('sz' bytes long, containing--- 'count' bytes of data) to handle (handle must be block or line buffered).-commitBuffer :: Handle                       -- handle to commit to-             -> RawCharBuffer -> Int         -- address and size (in bytes) of buffer-             -> Int                          -- number of bytes of data in buffer-             -> Bool                         -- True <=> flush the handle afterward-             -> Bool                         -- release the buffer?-             -> IO ()-commitBuffer hdl !raw !sz !count flush release =-  wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do-    let debugMsg = ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count-                    ++ ", flush=" ++ show flush ++ ", release=" ++ show release-                    ++ ", handle=" ++ show hdl)-    debugIO debugMsg-      -- Offset taken from handle-    writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer, bufOffset=0,-                               bufL=0, bufR=count, bufSize=sz }-    when flush $ flushByteWriteBuffer h_-    -- release the buffer if necessary-    when release $ do-      -- find size of current buffer-      old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer-      when (sz == size) $ do-        spare_bufs <- readIORef haBuffers-        writeIORef haBuffers (BufferListCons raw spare_bufs)-    -- bb <- readIORef haByteBuffer-    -- debugIO ("commitBuffer: buffer=" ++ summaryBuffer bb ++ ", handle=" ++ show hdl)---- backwards compatibility; the text package uses this-commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__-              -> IO CharBuffer-commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}-   = do-      debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count-            ++ ", flush=" ++ show flush ++ ", release=" ++ show release)--      let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,-                             bufL=0, bufR=count, bufSize=sz, bufOffset=0 }--      writeCharBuffer h_ this_buf--      when flush $ flushByteWriteBuffer h_--      -- release the buffer if necessary-      when release $ do-          -- find size of current buffer-          old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer-          when (sz == size) $ do-               spare_bufs <- readIORef haBuffers-               writeIORef haBuffers (BufferListCons raw spare_bufs)--      return this_buf---- ------------------------------------------------------------------------------ Reading/writing sequences of bytes.---- ------------------------------------------------------------------------------ hPutBuf---- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the--- buffer @buf@ to the handle @hdl@.  It returns ().------ 'hPutBuf' ignores any text encoding that applies to the 'Handle',--- writing the bytes directly to the underlying file or device.------ 'hPutBuf' ignores the prevailing 'System.IO.TextEncoding' and--- 'NewlineMode' on the 'Handle', and writes bytes directly.------ This operation may fail with:------  * 'ResourceVanished' if the handle is a pipe or socket, and the---    reading end is closed.  (If this is a POSIX system, and the program---    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered---    instead, whose default action is to terminate the program).--hPutBuf :: Handle                       -- handle to write to-        -> Ptr a                        -- address of buffer-        -> Int                          -- number of bytes of data in buffer-        -> IO ()-hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True-                         return ()--hPutBufNonBlocking-        :: Handle                       -- handle to write to-        -> Ptr a                        -- address of buffer-        -> Int                          -- number of bytes of data in buffer-        -> IO Int                       -- returns: number of bytes written-hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False--hPutBuf':: Handle                       -- handle to write to-        -> Ptr a                        -- address of buffer-        -> Int                          -- number of bytes of data in buffer-        -> Bool                         -- allow blocking?-        -> IO Int-hPutBuf' handle ptr count can_block-  | count == 0 = return 0-  | count <  0 = illegalBufferSize handle "hPutBuf" count-  | otherwise =-    wantWritableHandle "hPutBuf" handle $-      \ h_@Handle__{..} -> do-          debugIO ("hPutBuf count=" ++ show count)--          r <- bufWrite h_ (castPtr ptr) count can_block--          -- we must flush if this Handle is set to NoBuffering.  If-          -- it is set to LineBuffering, be conservative and flush-          -- anyway (we didn't check for newlines in the data).-          case haBufferMode of-             BlockBuffering _      -> return ()-             _line_or_no_buffering -> flushWriteBuffer h_-          return r---- TODO: Possible optimisation:---       If we know that `w + count > size`, we should write both the---       handle buffer and the `ptr` in a single `writev()` syscall.-bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int-bufWrite h_@Handle__{..} ptr !count can_block = do-  -- Get buffer to determine size and free space in buffer-  old_buf@Buffer{ bufR=w, bufSize=size }-      <- readIORef haByteBuffer--  -- There's no need to buffer if the incoming data is larger than-  -- the handle buffer (`count >= size`).-  -- Check if we can try to buffer the given chunk of data.-  b <- if (count < size && count <= size - w)-        then bufferChunk h_ old_buf ptr count-        else do-          -- The given data does not fit into the buffer.-          -- Either because it's too large for the buffer-          -- or the buffer is too full. Either way we need-          -- to flush the buffered data first.-          flushed_buf <- flushByteWriteBufferGiven h_ old_buf-          if count < size-              -- The data is small enough to be buffered.-              then bufferChunk h_ flushed_buf ptr count-              else do-                let offset = bufOffset flushed_buf-                !bytes <- if can_block-                            then writeChunk            h_ (castPtr ptr) offset count-                            else writeChunkNonBlocking h_ (castPtr ptr) offset count-                -- Update buffer with actual bytes written.-                writeIORef haByteBuffer $! bufferAddOffset bytes flushed_buf-                return bytes-  debugIO "hPutBuf: done"-  return b---- Flush the given buffer via the handle, return the flushed buffer-flushByteWriteBufferGiven :: Handle__ -> Buffer Word8 -> IO (Buffer Word8)-flushByteWriteBufferGiven h_@Handle__{..} bbuf =-  if (not (isEmptyBuffer bbuf))-    then do-      bbuf' <- Buffered.flushWriteBuffer haDevice bbuf-      debugIO ("flushByteWriteBufferGiven: bbuf=" ++ summaryBuffer bbuf')-      writeIORef haByteBuffer bbuf'-      return bbuf'-    else-      return bbuf---- Fill buffer and return bytes buffered/written.--- Flushes buffer if it's full after adding the data.-bufferChunk :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> IO Int-bufferChunk h_@Handle__{..} old_buf@Buffer{ bufRaw=raw, bufR=w, bufSize=size } ptr !count = do-    debugIO ("hPutBuf: copying to buffer, w=" ++ show w)-    copyToRawBuffer raw w ptr count-    let copied_buf = old_buf{ bufR = w + count }-    -- If the write filled the buffer completely, we need to flush,-    -- to maintain the "INVARIANTS on Buffers" from-    -- GHC.IO.Buffer.checkBuffer: "a write buffer is never full".-    if isFullBuffer copied_buf-      then do-        -- TODO: we should do a non-blocking flush here-        debugIO "hPutBuf: flushing full buffer after writing"-        _ <- flushByteWriteBufferGiven h_ copied_buf-        return ()-      else-        writeIORef haByteBuffer copied_buf-    return count--writeChunk :: Handle__ -> Ptr Word8 -> Word64 -> Int -> IO Int-writeChunk h_@Handle__{..} ptr offset bytes-  = do RawIO.write haDevice ptr offset bytes-       return bytes--writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Word64 -> Int -> IO Int-writeChunkNonBlocking h_@Handle__{..} ptr offset bytes-  = RawIO.writeNonBlocking haDevice ptr offset bytes---- ------------------------------------------------------------------------------ hGetBuf---- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@--- into the buffer @buf@ until either EOF is reached or--- @count@ 8-bit bytes have been read.--- It returns the number of bytes actually read.  This may be zero if--- EOF was reached before any data was read (or if @count@ is zero).------ 'hGetBuf' never raises an EOF exception, instead it returns a value--- smaller than @count@.------ If the handle is a pipe or socket, and the writing end--- is closed, 'hGetBuf' will behave as if EOF was reached.------ 'hGetBuf' ignores the prevailing 'System.IO.TextEncoding' and 'NewlineMode'--- on the 'Handle', and reads bytes directly.--hGetBuf :: Handle -> Ptr a -> Int -> IO Int-hGetBuf h !ptr count-  | count == 0 = return 0-  | count <  0 = illegalBufferSize h "hGetBuf" count-  | otherwise =-      wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do-          debugIO $ ":: hGetBuf - " ++ show h ++ " - " ++ show count-          flushCharReadBuffer h_-          buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }-            <- readIORef haByteBuffer-          debugIO ("hGetBuf: " ++ summaryBuffer buf)-          res <- if isEmptyBuffer buf-                    then bufReadEmpty    h_ buf (castPtr ptr) 0 count-                    else bufReadNonEmpty h_ buf (castPtr ptr) 0 count-          debugIO "** hGetBuf done."-          return res---- small reads go through the buffer, large reads are satisfied by--- taking data first from the buffer and then direct from the file--- descriptor.--bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int-bufReadNonEmpty h_@Handle__{..}-                -- w for width, r for ... read ptr?-                buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }-                ptr !so_far !count- = do-        debugIO ":: bufReadNonEmpty"-        -- We use < instead of <= because for count == avail-        -- we need to reset bufL and bufR to zero.-        -- See also: INVARIANTS on Buffers-        let avail = w - r-        if (count < avail)-           then do-                copyFromRawBuffer ptr raw r count-                writeIORef haByteBuffer buf{ bufL = r + count }-                return (so_far + count)-           else do--        copyFromRawBuffer ptr raw r avail-        let buf' = buf{ bufR=0, bufL=0 }-        writeIORef haByteBuffer buf'-        let remaining = count - avail-            so_far' = so_far + avail-            ptr' = ptr `plusPtr` avail--        debugIO ("bufReadNonEmpty: " ++ summaryBuffer buf' ++ " s:" ++ show so_far' ++ " r:" ++ show remaining)-        b <- if remaining == 0-           then return so_far'-           else bufReadEmpty h_ buf' ptr' so_far' remaining-        debugIO ":: bufReadNonEmpty - done"-        return b---- We want to read more data, but the buffer is empty. (buffL == buffR == 0)--- See also Note [INVARIANTS on Buffers] in Buffer.hs-bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int-bufReadEmpty h_@Handle__{..}-             buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz, bufOffset=bff }-             ptr so_far count- | count > sz- = do-        bytes_read <- loop haDevice 0 bff count-        -- bytes_read includes so_far (content that was in the buffer)-        -- but that is already accounted for in the old offset, so don't-        -- count it twice.-        let buf1 = bufferAddOffset (fromIntegral $ bytes_read - so_far) buf-        writeIORef haByteBuffer buf1-        debugIO ("bufReadEmpty1.1: " ++ summaryBuffer buf1 ++ " read:" ++ show bytes_read)-        return bytes_read- | otherwise = do-        (r,buf') <- Buffered.fillReadBuffer haDevice buf-        writeIORef haByteBuffer buf'-        if r == 0 -- end of file reached-            then return so_far-            else bufReadNonEmpty h_ buf' ptr so_far count- where-  -- Read @bytes@ byte into ptr. Repeating the read until either zero-  -- bytes where read, or we are done reading.-  loop :: RawIO.RawIO dev => dev -> Int -> Word64 -> Int -> IO Int-  loop dev delta off bytes | bytes <= 0 = return (so_far + delta)-  loop dev delta off bytes = do-    r <- RawIO.read dev (ptr `plusPtr` delta) off bytes-    debugIO $ show ptr ++ " - loop read@" ++ show delta ++ ": " ++ show r-    debugIO $ "next:" ++ show (delta + r) ++ " - left:" ++ show (bytes - r)-    if r == 0-        then return (so_far + delta)-        else loop dev (delta + r) (off + fromIntegral r) (bytes - r)---- ------------------------------------------------------------------------------ hGetBufSome---- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@--- into the buffer @buf@.  If there is any data available to read,--- then 'hGetBufSome' returns it immediately; it only blocks if there--- is no data to be read.------ It returns the number of bytes actually read.  This may be zero if--- EOF was reached before any data was read (or if @count@ is zero).------ 'hGetBufSome' never raises an EOF exception, instead it returns a value--- smaller than @count@.------ If the handle is a pipe or socket, and the writing end--- is closed, 'hGetBufSome' will behave as if EOF was reached.------ 'hGetBufSome' ignores the prevailing 'System.IO.TextEncoding' and--- 'NewlineMode' on the 'Handle', and reads bytes directly.--hGetBufSome :: Handle -> Ptr a -> Int -> IO Int-hGetBufSome h !ptr count-  | count == 0 = return 0-  | count <  0 = illegalBufferSize h "hGetBufSome" count-  | otherwise =-      wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do-         flushCharReadBuffer h_-         buf@Buffer{ bufSize=sz, bufOffset=offset } <- readIORef haByteBuffer-         if isEmptyBuffer buf-            then case count > sz of  -- large read? optimize it with a little special case:-                    True -> do bytes <- RawIO.read haDevice (castPtr ptr) offset count-                               -- Update buffer with actual bytes written.-                               writeIORef haByteBuffer $! bufferAddOffset bytes buf-                               return bytes-                    _ -> do (r,buf') <- Buffered.fillReadBuffer haDevice buf-                            if r == 0-                               then return 0-                               else do writeIORef haByteBuffer buf'-                                       bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count)-                                        -- new count is  (min r count), so-                                        -- that bufReadNBNonEmpty will not-                                        -- issue another read.-            else-              let count' = min count (bufferElems buf)-              in bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count'---- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@--- into the buffer @buf@ until either EOF is reached, or--- @count@ 8-bit bytes have been read, or there is no more data available--- to read immediately.------ 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will--- never block waiting for data to become available, instead it returns--- only whatever data is available.  To wait for data to arrive before--- calling 'hGetBufNonBlocking', use 'hWaitForInput'.------ If the handle is a pipe or socket, and the writing end--- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.------ 'hGetBufNonBlocking' ignores the prevailing 'System.IO.TextEncoding' and--- 'NewlineMode' on the 'Handle', and reads bytes directly.------ NOTE: on Windows, this function does not work correctly; it--- behaves identically to 'hGetBuf'.--hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int-hGetBufNonBlocking h !ptr count-  | count == 0 = return 0-  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count-  | otherwise =-      wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do-         flushCharReadBuffer h_-         buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }-            <- readIORef haByteBuffer-         if isEmptyBuffer buf-            then bufReadNBEmpty    h_ buf (castPtr ptr) 0 count-            else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count--bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int-bufReadNBEmpty   h_@Handle__{..}-                 buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz-                           , bufOffset=offset }-                 ptr so_far count-  | count > sz = do-       m <- RawIO.readNonBlocking haDevice ptr offset count-       case m of-         Nothing -> return so_far-         Just n  -> do -- Update buffer with actual bytes written.-                       writeIORef haByteBuffer $! bufferAddOffset n buf-                       return (so_far + n)-- | otherwise = do-    --  buf <- readIORef haByteBuffer-     (r,buf') <- Buffered.fillReadBuffer0 haDevice buf-     case r of-       Nothing -> return so_far-       Just 0  -> return so_far-       Just r'  -> do-         writeIORef haByteBuffer buf'-         bufReadNBNonEmpty h_ buf' ptr so_far (min count r')-                          -- NOTE: new count is    min count r'-                          -- so we will just copy the contents of the-                          -- buffer in the recursive call, and not-                          -- loop again.---bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int-bufReadNBNonEmpty h_@Handle__{..}-                  buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }-                  ptr so_far count-  = do-        let avail = w - r-        -- We use < instead of <= because for count == avail-        -- we need to reset bufL and bufR to zero.-        -- See also [INVARIANTS on Buffers] in Buffer.hs-        if (count < avail)-           then do-                copyFromRawBuffer ptr raw r count-                writeIORef haByteBuffer buf{ bufL = r + count }-                return (so_far + count)-           else do--        copyFromRawBuffer ptr raw r avail-        let buf' = buf{ bufR=0, bufL=0 }-        writeIORef haByteBuffer buf'-        let remaining = count - avail-            so_far' = so_far + avail-            ptr' = ptr `plusPtr` avail--        if remaining == 0-           then return so_far'-           else bufReadNBEmpty h_ buf' ptr' so_far' remaining---- ------------------------------------------------------------------------------ memcpy wrappers--copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()-copyToRawBuffer raw off ptr bytes =- withRawBuffer raw $ \praw ->-   do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)-      return ()--copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()-copyFromRawBuffer ptr raw off bytes =- withRawBuffer raw $ \praw ->-   do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)-      return ()--foreign import ccall unsafe "memcpy"-   memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())---------------------------------------------------------------------------------- Internal Utils--illegalBufferSize :: Handle -> String -> Int -> IO a-illegalBufferSize handle fn sz =-        ioException (IOError (Just handle)-                            InvalidArgument  fn-                            ("illegal buffer size " ++ showsPrec 9 sz [])-                            Nothing Nothing)-
− GHC/IO/Handle/Types.hs 
@@ -1,448 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP-           , NoImplicitPrelude-           , ExistentialQuantification-  #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Handle.Types--- Copyright   :  (c) The University of Glasgow, 1994-2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Basic types for the implementation of IO Handles.-----------------------------------------------------------------------------------module GHC.IO.Handle.Types (-      Handle(..), Handle__(..), showHandle,-      checkHandleInvariants,-      BufferList(..),-      HandleType(..),-      isReadableHandleType, isWritableHandleType, isReadWriteHandleType,-      isAppendHandleType,-      BufferMode(..),-      BufferCodec(..),-      NewlineMode(..), Newline(..), nativeNewline,-      universalNewlineMode, noNewlineTranslation, nativeNewlineMode-  ) where--#undef DEBUG--import GHC.Base-import GHC.MVar-import GHC.IO-import GHC.IO.Buffer-import GHC.IO.BufferedIO-import GHC.IO.Encoding.Types-import GHC.IORef-import GHC.Show-import GHC.Read-import GHC.Word-import GHC.IO.Device-import Data.Typeable-#if defined(DEBUG)-import Control.Monad-#endif---- ------------------------------------------------------------------------------ Handle type----  A Handle is represented by (a reference to) a record---  containing the state of the I/O port/device. We record---  the following pieces of info:----    * type (read,write,closed etc.)---    * the underlying file descriptor---    * buffering mode---    * buffer, and spare buffers---    * user-friendly name (usually the---      FilePath used when IO.openFile was called)---- Note: when a Handle is garbage collected, we want to flush its buffer--- and close the OS file handle, so as to free up a (precious) resource.---- | Haskell defines operations to read and write characters from and to files,--- represented by values of type @Handle@.  Each value of this type is a--- /handle/: a record used by the Haskell run-time system to /manage/ I\/O--- with file system objects.  A handle has at least the following properties:------  * whether it manages input or output or both;------  * whether it is /open/, /closed/ or /semi-closed/;------  * whether the object is seekable;------  * whether buffering is disabled, or enabled on a line or block basis;------  * a buffer (whose length may be zero).------ Most handles will also have a current I\/O position indicating where the next--- input or output operation will occur.  A handle is /readable/ if it--- manages only input or both input and output; likewise, it is /writable/ if--- it manages only output or both input and output.  A handle is /open/ when--- first allocated.--- Once it is closed it can no longer be used for either input or output,--- though an implementation cannot re-use its storage while references--- remain to it.  Handles are in the 'Show' and 'Eq' classes.  The string--- produced by showing a handle is system dependent; it should include--- enough information to identify the handle for debugging.  A handle is--- equal according to '==' only to itself; no attempt--- is made to compare the internal state of different handles for equality.--data Handle-  = FileHandle                          -- A normal handle to a file-        FilePath                        -- the file (used for error messages-                                        -- only)-        !(MVar Handle__)--  | DuplexHandle                        -- A handle to a read/write stream-        FilePath                        -- file for a FIFO, otherwise some-                                        --   descriptive string (used for error-                                        --   messages only)-        !(MVar Handle__)                -- The read side-        !(MVar Handle__)                -- The write side---- NOTES:---    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be---      seekable.---- | @since 4.1.0.0-instance Eq Handle where- (FileHandle _ h1)     == (FileHandle _ h2)     = h1 == h2- (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2- _ == _ = False--data Handle__-  = forall dev enc_state dec_state . (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) =>-    Handle__ {-      haDevice      :: !dev,-      haType        :: HandleType,           -- type (read/write/append etc.)-      haByteBuffer  :: !(IORef (Buffer Word8)), -- See [note Buffering Implementation]-      haBufferMode  :: BufferMode,-      haLastDecode  :: !(IORef (dec_state, Buffer Word8)),-      -- ^ The byte buffer just  before we did our last batch of decoding.-      haCharBuffer  :: !(IORef (Buffer CharBufElem)), -- See [note Buffering Implementation]-      haBuffers     :: !(IORef (BufferList CharBufElem)),  -- spare buffers-      haEncoder     :: Maybe (TextEncoder enc_state),-      haDecoder     :: Maybe (TextDecoder dec_state),-      haCodec       :: Maybe TextEncoding,-      haInputNL     :: Newline,-      haOutputNL    :: Newline,-      haOtherSide   :: Maybe (MVar Handle__) -- ptr to the write side of a-                                             -- duplex handle.-    }---- 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--- same size as the main buffer.-data BufferList e-  = BufferListNil-  | BufferListCons (RawBuffer e) (BufferList e)----  Internally, we classify handles as being one---  of the following:--data HandleType- = ClosedHandle- | SemiClosedHandle- | ReadHandle- | WriteHandle- | AppendHandle- | ReadWriteHandle--isReadableHandleType :: HandleType -> Bool-isReadableHandleType ReadHandle         = True-isReadableHandleType ReadWriteHandle    = True-isReadableHandleType _                  = False--isWritableHandleType :: HandleType -> Bool-isWritableHandleType AppendHandle    = True-isWritableHandleType WriteHandle     = True-isWritableHandleType ReadWriteHandle = True-isWritableHandleType _               = False--isReadWriteHandleType :: HandleType -> Bool-isReadWriteHandleType ReadWriteHandle{} = True-isReadWriteHandleType _                 = False--isAppendHandleType :: HandleType -> Bool-isAppendHandleType AppendHandle = True-isAppendHandleType _            = False----- INVARIANTS on Handles:------   * A handle *always* has a buffer, even if it is only 1 character long---     (an unbuffered handle needs a 1 character buffer in order to support---      hLookAhead and hIsEOF).---   * In a read Handle, the byte buffer is always empty (we decode when reading)---   * In a wriite Handle, the Char buffer is always empty (we encode when writing)----checkHandleInvariants :: Handle__ -> IO ()-#if defined(DEBUG)-checkHandleInvariants h_ = do- bbuf <- readIORef (haByteBuffer h_)- checkBuffer bbuf- cbuf <- readIORef (haCharBuffer h_)- checkBuffer cbuf- when (isWriteBuffer cbuf && not (isEmptyBuffer cbuf)) $-   errorWithoutStackTrace ("checkHandleInvariants: char write buffer non-empty: " ++-          summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf)- when (isWriteBuffer bbuf /= isWriteBuffer cbuf) $-   errorWithoutStackTrace ("checkHandleInvariants: buffer modes differ: " ++-          summaryBuffer bbuf ++ ", " ++ summaryBuffer cbuf)--#else-checkHandleInvariants _ = return ()-#endif---- ------------------------------------------------------------------------------ Buffering modes---- | Three kinds of buffering are supported: line-buffering,--- block-buffering or no-buffering.  These modes have the following--- effects. For output, items are written out, or /flushed/,--- from the internal buffer according to the buffer mode:------  * /line-buffering/: the entire output buffer is flushed---    whenever a newline is output, the buffer overflows,---    a 'System.IO.hFlush' is issued, or the handle is closed.------  * /block-buffering/: the entire buffer is written out whenever it---    overflows, a 'System.IO.hFlush' is issued, or the handle is closed.------  * /no-buffering/: output is written immediately, and never stored---    in the buffer.------ An implementation is free to flush the buffer more frequently,--- but not less frequently, than specified above.--- The output buffer is emptied as soon as it has been written out.------ Similarly, input occurs according to the buffer mode for the handle:------  * /line-buffering/: when the buffer for the handle is not empty,---    the next item is obtained from the buffer; otherwise, when the---    buffer is empty, characters up to and including the next newline---    character are read into the buffer.  No characters are available---    until the newline character is available or the buffer is full.------  * /block-buffering/: when the buffer for the handle becomes empty,---    the next block of data is read into the buffer.------  * /no-buffering/: the next input item is read and returned.---    The 'System.IO.hLookAhead' operation implies that even a no-buffered---    handle may require a one-character buffer.------ The default buffering mode when a handle is opened is--- implementation-dependent and may depend on the file system object--- which is attached to that handle.--- For most implementations, physical files will normally be block-buffered--- and terminals will normally be line-buffered.--data BufferMode- = NoBuffering  -- ^ buffering is disabled if possible.- | LineBuffering-                -- ^ line-buffering should be enabled if possible.- | BlockBuffering (Maybe Int)-                -- ^ block-buffering should be enabled if possible.-                -- The size of the buffer is @n@ items if the argument-                -- is 'Just' @n@ and is otherwise implementation-dependent.-   deriving ( Eq   -- ^ @since 4.2.0.0-            , Ord  -- ^ @since 4.2.0.0-            , Read -- ^ @since 4.2.0.0-            , Show -- ^ @since 4.2.0.0-            )--{--[note Buffering Implementation]--Each Handle has two buffers: a byte buffer (haByteBuffer) and a Char-buffer (haCharBuffer).--[note Buffered Reading]--For read Handles, bytes are read into the byte buffer, and immediately-decoded into the Char buffer (see-GHC.IO.Handle.Internals.readTextDevice).  The only way there might be-some data left in the byte buffer is if there is a partial multi-byte-character sequence that cannot be decoded into a full character.--Note that the buffering mode (haBufferMode) makes no difference when-reading data into a Handle.  When reading, we can always just read all-the data there is available without blocking, decode it into the Char-buffer, and then provide it immediately to the caller.--[note Buffered Writing]--Characters are written into the Char buffer by e.g. hPutStr.  At the-end of the operation, or when the char buffer is full, the buffer is-decoded to the byte buffer (see writeCharBuffer).  This is so that we-can detect encoding errors at the right point.--Hence, the Char buffer is always empty between Handle operations.--[note Buffer Sizing]--The char buffer is always a default size (dEFAULT_CHAR_BUFFER_SIZE).-The byte buffer size is chosen by the underlying device (via its-IODevice.newBuffer).  Hence the size of these buffers is not under-user control.--There are certain minimum sizes for these buffers imposed by the-library (but not checked):-- - we must be able to buffer at least one character, so that-   hLookAhead can work-- - the byte buffer must be able to store at least one encoded-   character in the current encoding (6 bytes?)-- - when reading, the char buffer must have room for two characters, so-   that we can spot the \r\n sequence.--How do we implement hSetBuffering?--For reading, we have never used the user-supplied buffer size, because-there's no point: we always pass all available data to the reader-immediately.  Buffering would imply waiting until a certain amount of-data is available, which has no advantages.  So hSetBuffering is-essentially a no-op for read handles, except that it turns on/off raw-mode for the underlying device if necessary.--For writing, the buffering mode is handled by the write operations-themselves (hPutChar and hPutStr).  Every write ends with-writeCharBuffer, which checks whether the buffer should be flushed-according to the current buffering mode.  Additionally, we look for-newlines and flush if the mode is LineBuffering.--[note Buffer Flushing]--** Flushing the Char buffer--We must be able to flush the Char buffer, in order to implement-hSetEncoding, and things like hGetBuf which want to read raw bytes.--Flushing the Char buffer on a write Handle is easy: it is always empty.--Flushing the Char buffer on a read Handle involves rewinding the byte-buffer to the point representing the next Char in the Char buffer.-This is done by-- - remembering the state of the byte buffer *before* the last decode-- - re-decoding the bytes that represent the chars already read from the-   Char buffer.  This gives us the point in the byte buffer that-   represents the *next* Char to be read.--In order for this to work, after readTextHandle we must NOT MODIFY THE-CONTENTS OF THE BYTE OR CHAR BUFFERS, except to remove characters from-the Char buffer.--** Flushing the byte buffer--The byte buffer can be flushed if the Char buffer has already been-flushed (see above).  For a read Handle, flushing the byte buffer-means seeking the device back by the number of bytes in the buffer,-and hence it is only possible on a seekable Handle.---}---- ------------------------------------------------------------------------------ Newline translation---- | The representation of a newline in the external file or stream.-data Newline = LF    -- ^ @\'\\n\'@-             | CRLF  -- ^ @\'\\r\\n\'@-             deriving ( Eq   -- ^ @since 4.2.0.0-                      , Ord  -- ^ @since 4.3.0.0-                      , Read -- ^ @since 4.3.0.0-                      , Show -- ^ @since 4.3.0.0-                      )---- | Specifies the translation, if any, of newline characters between--- internal Strings and the external file or stream.  Haskell Strings--- are assumed to represent newlines with the @\'\\n\'@ character; the--- newline mode specifies how to translate @\'\\n\'@ on output, and what to--- translate into @\'\\n\'@ on input.-data NewlineMode-  = NewlineMode { inputNL :: Newline,-                    -- ^ the representation of newlines on input-                  outputNL :: Newline-                    -- ^ the representation of newlines on output-                 }-             deriving ( Eq   -- ^ @since 4.2.0.0-                      , Ord  -- ^ @since 4.3.0.0-                      , Read -- ^ @since 4.3.0.0-                      , Show -- ^ @since 4.3.0.0-                      )---- | The native newline representation for the current platform: 'LF'--- on Unix systems, 'CRLF' on Windows.-nativeNewline :: Newline-#if defined(mingw32_HOST_OS)-nativeNewline = CRLF-#else-nativeNewline = LF-#endif---- | Map @\'\\r\\n\'@ into @\'\\n\'@ on input, and @\'\\n\'@ to the native newline--- representation on output.  This mode can be used on any platform, and--- works with text files using any newline convention.  The downside is--- that @readFile >>= writeFile@ might yield a different file.------ > universalNewlineMode  = NewlineMode { inputNL  = CRLF,--- >                                       outputNL = nativeNewline }----universalNewlineMode :: NewlineMode-universalNewlineMode  = NewlineMode { inputNL  = CRLF,-                                      outputNL = nativeNewline }---- | Use the native newline representation on both input and output------ > nativeNewlineMode  = NewlineMode { inputNL  = nativeNewline--- >                                    outputNL = nativeNewline }----nativeNewlineMode    :: NewlineMode-nativeNewlineMode     = NewlineMode { inputNL  = nativeNewline,-                                      outputNL = nativeNewline }---- | Do no newline translation at all.------ > noNewlineTranslation  = NewlineMode { inputNL  = LF, outputNL = LF }----noNewlineTranslation :: NewlineMode-noNewlineTranslation  = NewlineMode { inputNL  = LF, outputNL = LF }---- ------------------------------------------------------------------------------ Show instance for Handles---- handle types are 'show'n when printing error msgs, so--- we provide a more user-friendly Show instance for it--- than the derived one.---- | @since 4.1.0.0-instance Show HandleType where-  showsPrec _ t =-    case t of-      ClosedHandle      -> showString "closed"-      SemiClosedHandle  -> showString "semi-closed"-      ReadHandle        -> showString "readable"-      WriteHandle       -> showString "writable"-      AppendHandle      -> showString "writable (append)"-      ReadWriteHandle   -> showString "read-writable"---- | @since 4.1.0.0-instance Show Handle where-  showsPrec _ (FileHandle   file _)   = showHandle file-  showsPrec _ (DuplexHandle file _ _) = showHandle file--showHandle :: FilePath -> String -> String-showHandle file = showString "{handle: " . showString file . showString "}"-
− GHC/IO/Handle/Windows.hs 
@@ -1,237 +0,0 @@-  {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Handle.Windows--- Copyright   :  (c) The University of Glasgow, 2017--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Handle operations implemented by Windows native handles-----------------------------------------------------------------------------------module GHC.IO.Handle.Windows (-  stdin, stdout, stderr,-  openFile, openBinaryFile, openFileBlocking,-  handleToHANDLE, mkHandleFromHANDLE- ) where--import Data.Maybe-import Data.Typeable--import GHC.Base-import GHC.MVar-import GHC.IO-import GHC.IO.BufferedIO hiding (flushWriteBuffer)-import GHC.IO.Encoding-import GHC.IO.Device as IODevice-import GHC.IO.Exception-import GHC.IO.IOMode-import GHC.IO.Handle.Types-import GHC.IO.Handle.Internals-import qualified GHC.IO.Windows.Handle as Win---- ------------------------------------------------------------------------------ Standard Handles---- Three handles are allocated during program initialisation.  The first--- two manage input or output from the Haskell program's standard input--- or output channel respectively.  The third manages output to the--- standard error channel. These handles are initially open.---- | If the std handles are redirected to file handles then WriteConsole etc---   won't work anymore. When the handle is created test it and if it's a file---   handle then just convert it to the proper IODevice so WriteFile is used---   instead. This is done here so it's buffered and only happens once.-mkConsoleHandle :: Win.IoHandle Win.ConsoleHandle-                -> FilePath-                -> HandleType-                -> Bool                     -- buffered?-                -> Maybe TextEncoding-                -> NewlineMode-                -> Maybe HandleFinalizer-                -> Maybe (MVar Handle__)-                -> IO Handle-mkConsoleHandle dev filepath ha_type buffered mb_codec nl finalizer other_side- = do isTerm <- IODevice.isTerminal dev-      case isTerm of-        True  -> mkHandle dev filepath ha_type buffered mb_codec nl finalizer-                          other_side-        False -> mkHandle (Win.convertHandle dev False) filepath ha_type buffered-                            mb_codec nl finalizer other_side---- | A handle managing input from the Haskell program's standard input channel.-stdin :: Handle-{-# NOINLINE stdin #-}-stdin = unsafePerformIO $ do-   enc <- getLocaleEncoding-   mkConsoleHandle Win.stdin "<stdin>" ReadHandle True (Just enc)-                   nativeNewlineMode{-translate newlines-}-                   (Just stdHandleFinalizer) Nothing---- | A handle managing output to the Haskell program's standard output channel.-stdout :: Handle-{-# NOINLINE stdout #-}-stdout = unsafePerformIO $ do-   enc <- getLocaleEncoding-   mkConsoleHandle Win.stdout "<stdout>" WriteHandle True (Just enc)-                   nativeNewlineMode{-translate newlines-}-                   (Just stdHandleFinalizer) Nothing---- | A handle managing output to the Haskell program's standard error channel.-stderr :: Handle-{-# NOINLINE stderr #-}-stderr = unsafePerformIO $ do-   enc <- getLocaleEncoding-   mkConsoleHandle Win.stderr "<stderr>" WriteHandle-                   False{-stderr is unbuffered-} (Just enc)-                   nativeNewlineMode{-translate newlines-}-                  (Just stdHandleFinalizer) Nothing--stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()-stdHandleFinalizer fp m = do-  h_ <- takeMVar m-  flushWriteBuffer h_-  case haType h_ of-      ClosedHandle -> return ()-      _other       -> closeTextCodecs h_-  putMVar m (ioe_finalizedHandle fp)---- ------------------------------------------------------------------------------ Opening and Closing Files--addFilePathToIOError :: String -> FilePath -> IOException -> IOException-addFilePathToIOError fun fp ioe-  = ioe{ ioe_location = fun, ioe_filename = Just fp }---- | Computation 'openFile' @file mode@ allocates and returns a new, open--- handle to manage the file @file@.  It manages input if @mode@--- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',--- and both input and output if mode is 'ReadWriteMode'.------ If the file does not exist and it is opened for output, it should be--- created as a new file.  If @mode@ is 'WriteMode' and the file--- already exists, then it should be truncated to zero length.--- Some operating systems delete empty files, so there is no guarantee--- that the file will exist following an 'openFile' with @mode@--- 'WriteMode' unless it is subsequently written to successfully.--- The handle is positioned at the end of the file if @mode@ is--- 'AppendMode', and otherwise at the beginning (in which case its--- internal position is 0).--- The initial buffer mode is implementation-dependent.------ This operation may fail with:------  * 'isAlreadyInUseError' if the file is already open and cannot be reopened;------  * 'isDoesNotExistError' if the file does not exist; or------  * 'isPermissionError' if the user does not have permission to open the file.------ Note: if you will be working with files containing binary data, you'll want to--- be using 'openBinaryFile'.-openFile :: FilePath -> IOMode -> IO Handle-openFile fp im =-  catchException-    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)-    (\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 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-openFileBlocking fp im =-  catchException-    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)-    (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e))---- | Like 'openFile', but open the file in binary mode.--- On Windows, reading a file in text mode (which is the default)--- will translate CRLF to LF, and writing will translate LF to CRLF.--- This is usually what you want with text files.  With binary files--- this is undesirable; also, as usual under Microsoft operating systems,--- text mode treats control-Z as EOF.  Binary mode turns off all special--- treatment of end-of-line and end-of-file characters.--- (See also 'hSetBinaryMode'.)--openBinaryFile :: FilePath -> IOMode -> IO Handle-openBinaryFile fp m =-  catchException-    (openFile' fp m True True)-    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))--openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle-openFile' filepath iomode binary non_blocking = do-  -- first open the file to get a Win32 handle-  (hwnd, hwnd_type) <- Win.openFile filepath iomode non_blocking--  mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding--  -- then use it to make a Handle-  mkHandleFromHANDLE hwnd hwnd_type filepath iomode mb_codec-            `onException` IODevice.close hwnd-        -- NB. don't forget to close the Handle if mkHandleFromHANDLE fails,-        -- otherwise this Handle leaks.---- ------------------------------------------------------------------------------ Converting Windows Handles from/to Handles--mkHandleFromHANDLE-   :: (RawIO dev, IODevice.IODevice dev, BufferedIO dev, Typeable dev) => dev-   -> IODeviceType-   -> FilePath  -- a string describing this Windows handle (e.g. the filename)-   -> IOMode-   -> Maybe TextEncoding-   -> IO Handle--mkHandleFromHANDLE dev hw_type filepath iomode mb_codec-  = do-    let nl | isJust mb_codec = nativeNewlineMode-           | otherwise       = noNewlineTranslation--    case hw_type of-        Directory ->-           ioException (IOError Nothing InappropriateType "openFile"-                           "is a directory" Nothing Nothing)--        Stream-           -- only *Streams* can be DuplexHandles.  Other read/write-           -- Handles must share a buffer.-           | ReadWriteMode <- iomode ->-                mkDuplexHandle dev filepath mb_codec nl---        _other -> mkFileHandle dev filepath iomode mb_codec nl---- | Turn an existing Handle into a Win32 HANDLE. This function throws an--- IOError if the Handle does not reference a HANDLE-handleToHANDLE :: Handle -> IO Win.HANDLE-handleToHANDLE h = case h of-  FileHandle _ mv -> do-    Handle__{haDevice = dev} <- readMVar mv-    case (cast dev :: Maybe (Win.Io Win.NativeHandle),-          cast dev :: Maybe (Win.Io Win.ConsoleHandle)) of-      (Just hwnd, Nothing) -> return $ Win.toHANDLE hwnd-      (Nothing, Just hwnd) -> return $ Win.toHANDLE hwnd-      _                    -> throwErr "not a file HANDLE"-  DuplexHandle{} -> throwErr "not a file handle"-  where-    throwErr msg = ioException $ IOError (Just h)-      InappropriateType "handleToHANDLE" msg Nothing Nothing---- ------------------------------------------------------------------------------ Are files opened by default in text or binary mode, if the user doesn't--- specify? The thing is, to the Win32 APIs which are lowerlevel there exist no--- such thing as binary/text mode. That's strictly a thing of the C library on--- top of it.  So I'm not sure what to do with this. -Tamar--dEFAULT_OPEN_IN_BINARY_MODE :: Bool-dEFAULT_OPEN_IN_BINARY_MODE = False
− GHC/IO/IOMode.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.IOMode--- Copyright   :  (c) The University of Glasgow, 1994-2008--- License     :  see libraries/base/LICENSE--- --- Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ The IOMode type-----------------------------------------------------------------------------------module GHC.IO.IOMode (IOMode(..)) where--import GHC.Base-import GHC.Show-import GHC.Read-import GHC.Arr-import GHC.Enum---- | See 'System.IO.openFile'-data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode-                    deriving ( Eq   -- ^ @since 4.2.0.0-                             , Ord  -- ^ @since 4.2.0.0-                             , Ix   -- ^ @since 4.2.0.0-                             , Enum -- ^ @since 4.2.0.0-                             , Read -- ^ @since 4.2.0.0-                             , Show -- ^ @since 4.2.0.0-                             )-
− GHC/IO/StdHandles.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE Trustworthy       #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP               #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.StdHandles--- Copyright   :  (c) The University of Glasgow, 2017--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ This model abtracts away the platform specific handles that can be toggled--- through the RTS.-----------------------------------------------------------------------------------module GHC.IO.StdHandles-  ( -- std handles-    stdin, stdout, stderr,-    openFile, openBinaryFile, openFileBlocking,-    withFile, withBinaryFile, withFileBlocking-  ) where--import GHC.IO-import GHC.IO.IOMode-import GHC.IO.Handle.Types--import qualified GHC.IO.Handle.FD as POSIX-#if defined(mingw32_HOST_OS)-import GHC.IO.SubSystem-import qualified GHC.IO.Handle.Windows as Win-import GHC.IO.Handle.Internals (hClose_impl)--stdin :: Handle-stdin = POSIX.stdin <!> Win.stdin--stdout :: Handle-stdout = POSIX.stdout <!> Win.stdout--stderr :: Handle-stderr = POSIX.stderr <!> Win.stderr--openFile :: FilePath -> IOMode -> IO Handle-openFile = POSIX.openFile <!> Win.openFile---- TODO: implement as for POSIX-withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFile = POSIX.withFile <!> wf-  where-    wf path mode act = bracket (Win.openFile path mode) hClose_impl act--openBinaryFile :: FilePath -> IOMode -> IO Handle-openBinaryFile = POSIX.openBinaryFile <!> Win.openBinaryFile--withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withBinaryFile = POSIX.withBinaryFile <!> wf-  where-    wf path mode act = bracket (Win.openBinaryFile path mode) hClose_impl act--openFileBlocking :: FilePath -> IOMode -> IO Handle-openFileBlocking = POSIX.openFileBlocking <!> Win.openFileBlocking--withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFileBlocking = POSIX.withFileBlocking <!> wf-  where-    wf path mode act = bracket (Win.openFileBlocking path mode) hClose_impl act--#else--stdin :: Handle-stdin = POSIX.stdin--stdout :: Handle-stdout = POSIX.stdout--stderr :: Handle-stderr = POSIX.stderr--openFile :: FilePath -> IOMode -> IO Handle-openFile = POSIX.openFile--withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFile = POSIX.withFile--openBinaryFile :: FilePath -> IOMode -> IO Handle-openBinaryFile = POSIX.openBinaryFile--withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withBinaryFile = POSIX.withBinaryFile--openFileBlocking :: FilePath -> IOMode -> IO Handle-openFileBlocking = POSIX.openFileBlocking--withFileBlocking :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFileBlocking = POSIX.withFileBlocking--#endif
− GHC/IO/StdHandles.hs-boot 
@@ -1,23 +0,0 @@-{-# LANGUAGE Trustworthy       #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP               #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.StdHandles [boot]--- Copyright   :  (c) The University of Glasgow, 2017--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable-----------------------------------------------------------------------------------module GHC.IO.StdHandles where--import GHC.IO.Handle.Types---- used in GHC.Conc, which is below GHC.IO.Handle.FD-stdout :: Handle-
− GHC/IO/SubSystem.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE Trustworthy       #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP               #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.SubSystem--- Copyright   :  (c) The University of Glasgow, 2017--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ The SubSystem control interface.  These methods can be used to disambiguate--- between the two operations.-----------------------------------------------------------------------------------module GHC.IO.SubSystem (-  withIoSubSystem,-  withIoSubSystem',-  whenIoSubSystem,-  ioSubSystem,-  IoSubSystem(..),-  conditional,-  (<!>),-  isWindowsNativeIO- ) where--import GHC.Base-import GHC.RTS.Flags--#if defined(mingw32_HOST_OS)-import GHC.IO.Unsafe-#endif--infixl 7 <!>---- | Conditionally execute an action depending on the configured I/O subsystem.--- On POSIX systems always execute the first action.--- On windows execute the second action if WINIO as active, otherwise fall back to--- the first action.-conditional :: a -> a -> a-#if defined(mingw32_HOST_OS)-conditional posix windows =-  case ioSubSystem of-    IoPOSIX -> posix-    IoNative -> windows-#else-conditional posix _       = posix-#endif---- | Infix version of `conditional`.--- posix <!> windows == conditional posix windows-(<!>) :: a -> a -> a-(<!>) = conditional--isWindowsNativeIO :: Bool-isWindowsNativeIO = False <!> True--ioSubSystem :: IoSubSystem-#if defined(mingw32_HOST_OS)-{-# NOINLINE ioSubSystem #-}-ioSubSystem = unsafeDupablePerformIO getIoManagerFlag-#else-ioSubSystem = IoPOSIX-#endif--withIoSubSystem :: (IoSubSystem -> IO a) -> IO a-withIoSubSystem f = f ioSubSystem--withIoSubSystem' :: (IoSubSystem -> a) -> a-withIoSubSystem' f = f ioSubSystem--whenIoSubSystem :: IoSubSystem -> IO () -> IO ()-whenIoSubSystem m f = do let sub = ioSubSystem-                         when (sub == m) f-
− GHC/IO/Unsafe.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude-           , MagicHash-           , UnboxedTuples-  #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- 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--{- Note [unsafePerformIO and strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this sub-expression (from tests/lib/should_run/memo002)-- unsafePerformIO (do { lockMemoTable-                     ; let r = f x-                     ; updateMemoTable x r-                     ; unlockMemoTable-                     ; return r })--It's super-important that the `let r = f x` is lazy. If the demand-analyser sees that `r` is sure to be demanded, it'll use call-by-value-for (f x), that will try to lock the already-locked table => deadlock.-See #19181 and #19413.--Now `r` doesn't look strict, because it's wrapped in a `return`.-But if we were to define unsafePerformIO like this-  unsafePerformIO (IO m) = case runRW# m of (# _, r #) -> r--then we'll push that `case` inside the arugment to runRW#, givign-  runRW# (\s -> case lockMemoTable s of s1 ->-                let r = f x in-                case updateMemoTable s1 of s2 ->-                case unlockMemoTable s2 of _ ->-                r)--And now that `let` really does look strict.  No good!--Solution: wrap the result of the unsafePerformIO in 'lazy', to conceal-it from the demand analyser:-  unsafePerformIO (IO m) = case runRW# m of (# _, r #) -> lazy r-                                                 ------>  ^^^^-See also Note [lazyId magic] in GHC.Types.Id.Make--}--{-|-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 'Control.Exception.bracket' cannot be used safely within-'unsafeDupablePerformIO'.--@since 4.4.0.0--}-unsafeDupablePerformIO  :: IO a -> a--- See Note [unsafePerformIO and strictness]-unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> lazy a--{-|-'unsafeInterleaveIO' allows an '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)---- Note [unsafeDupableInterleaveIO should not be inlined]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ 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.--{-|-'unsafeDupableInterleaveIO' allows an '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.--The computation may be performed multiple times by different threads,-possibly at the same time. To ensure that the computation is performed-only once, use 'unsafeInterleaveIO' instead.--}--{-# NOINLINE unsafeDupableInterleaveIO #-}--- See Note [unsafeDupableInterleaveIO should not be inlined]-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', () #)
− GHC/IO/Windows/Encoding.hs 
@@ -1,218 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE NoImplicitPrelude    #-}-{- |-   Module      :  System.Win32.Encoding-   Copyright   :  2012 shelarcy-   License     :  BSD-style--   Maintainer  :  shelarcy@gmail.com-   Stability   :  Provisional-   Portability :  Non-portable (Win32 API)--   Enocode/Decode mutibyte character using Win32 API.--}--module GHC.IO.Windows.Encoding-  ( encodeMultiByte-  , encodeMultiByteIO-  , encodeMultiByteRawIO-  , decodeMultiByte-  , decodeMultiByteIO-  , wideCharToMultiByte-  , multiByteToWideChar-  , withGhcInternalToUTF16-  , withUTF16ToGhcInternal-  ) where--import Data.Word (Word8, Word16)-import Foreign.C.Types        (CInt(..))-import Foreign.C.String       (peekCAStringLen, peekCWStringLen,-                               withCWStringLen, withCAStringLen, )-import Foreign.Ptr (nullPtr, Ptr ())-import Foreign.Marshal.Array  (allocaArray)-import Foreign.Marshal.Unsafe (unsafeLocalState)-import GHC.Windows-import GHC.IO.Encoding.CodePage (CodePage, getCurrentCodePage)-import GHC.IO-import GHC.Base-import GHC.Real--#include "windows_cconv.h"---- | The "System.IO" output functions (e.g. `putStr`) don't--- automatically convert to multibyte string on Windows, so this--- function is provided to make the conversion from a Unicode string--- in the given code page to a proper multibyte string.  To get the--- code page for the console, use `getCurrentCodePage`.----encodeMultiByte :: CodePage -> String -> String-encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp--{-# INLINE encodeMultiByteIO' #-}--- | String must not be zero length.-encodeMultiByteIO' :: CodePage -> String -> ((LPCSTR, CInt) -> IO a) -> IO a-encodeMultiByteIO' cp wstr transformer =-  withCWStringLen wstr $ \(cwstr,len) -> do-    mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte-                cp-                0-                cwstr-                (fromIntegral len)-                nullPtr 0-                nullPtr nullPtr-    -- mbchar' is the length of buffer required-    allocaArray (fromIntegral mbchars') $ \mbstr -> do-      mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte-                 cp-                 0-                 cwstr-                 (fromIntegral len)-                 mbstr mbchars'-                 nullPtr nullPtr-      transformer (mbstr,fromIntegral mbchars)---- converts [Char] to UTF-16-encodeMultiByteIO :: CodePage -> String -> IO String-encodeMultiByteIO _ "" = return ""-encodeMultiByteIO cp s = encodeMultiByteIO' cp s toString-  where toString (st,l) = peekCAStringLen (st,fromIntegral l)---- converts [Char] to UTF-16-encodeMultiByteRawIO :: CodePage -> String -> IO (LPCSTR, CInt)-encodeMultiByteRawIO _ "" = return (nullPtr, 0)-encodeMultiByteRawIO cp s = encodeMultiByteIO' cp s toSizedCString-  where toSizedCString (st,l) = return (st, fromIntegral l)--foreign import WINDOWS_CCONV "WideCharToMultiByte"-  wideCharToMultiByte-        :: CodePage-        -> DWORD   -- dwFlags,-        -> LPCWSTR -- lpWideCharStr-        -> CInt    -- cchWideChar-        -> LPSTR   -- lpMultiByteStr-        -> CInt    -- cbMultiByte-        -> LPCSTR  -- lpMultiByteStr-        -> LPBOOL  -- lpbFlags-        -> IO CInt---- | The `System.IO` input functions (e.g. `getLine`) don't--- automatically convert to Unicode, so this function is provided to--- make the conversion from a multibyte string in the given code page--- to a proper Unicode string.  To get the code page for the console,--- use `getConsoleCP`.-stringToUnicode :: CodePage -> String -> IO String-stringToUnicode _cp "" = return ""-     -- MultiByteToWideChar doesn't handle empty strings (#1929)-stringToUnicode cp mbstr =-  withCAStringLen mbstr $ \(cstr,len) -> do-    wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar-                cp-                0-                cstr-                (fromIntegral len)-                nullPtr 0-    -- wchars is the length of buffer required-    allocaArray (fromIntegral wchars) $ \cwstr -> do-      wchars' <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar-                cp-                0-                cstr-                (fromIntegral len)-                cwstr wchars-      peekCWStringLen (cwstr,fromIntegral wchars')  -- converts UTF-16 to [Char]--foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar"-  multiByteToWideChar-        :: CodePage-        -> DWORD   -- dwFlags,-        -> LPCSTR  -- lpMultiByteStr-        -> CInt    -- cbMultiByte-        -> LPWSTR  -- lpWideCharStr-        -> CInt    -- cchWideChar-        -> IO CInt--decodeMultiByte :: CodePage -> String -> String-decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp---- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO`--- for alias of `stringToUnicode`.-decodeMultiByteIO :: CodePage -> String -> IO String-decodeMultiByteIO = stringToUnicode-{-# INLINE decodeMultiByteIO #-}--foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar"-  multiByteToWideChar'-        :: CodePage-        -> DWORD   -- dwFlags,-        -> Ptr Word8  -- lpMultiByteStr-        -> CInt    -- cbMultiByte-        -> Ptr Word16  -- lpWideCharStr-        -> CInt    -- cchWideChar-        -> IO CInt---- TODO: GHC is internally UTF-32 which means we have re-encode for---       Windows which is annoying. Switch to UTF-16 on IoNative---       being default.-withGhcInternalToUTF16 :: Ptr Word8 -> Int -> ((Ptr Word16, CInt) -> IO a)-                       -> IO a-withGhcInternalToUTF16 ptr len fn- = do cp <- getCurrentCodePage-      wchars <- failIfZero "withGhcInternalToUTF16" $-                  multiByteToWideChar' cp 0 ptr (fromIntegral len) nullPtr 0-      -- wchars is the length of buffer required-      allocaArray (fromIntegral wchars) $ \cwstr -> do-        wchars' <- failIfZero "withGhcInternalToUTF16" $-                    multiByteToWideChar' cp 0 ptr (fromIntegral len) cwstr wchars-        fn (cwstr, wchars')--foreign import WINDOWS_CCONV "WideCharToMultiByte"-  wideCharToMultiByte'-        :: CodePage-        -> DWORD   -- dwFlags,-        -> Ptr Word16 -- lpWideCharStr-        -> CInt    -- cchWideChar-        -> Ptr Word8   -- lpMultiByteStr-        -> CInt    -- cbMultiByte-        -> LPCSTR  -- lpMultiByteStr-        -> LPBOOL  -- lpbFlags-        -> IO CInt---- TODO: GHC is internally UTF-32 which means we have re-encode for---       Windows which is annoying. Switch to UTF-16 on IoNative---       being default.---- | Decode a UTF16 buffer into the given buffer in the current code page.--- The source UTF16 buffer is filled by the function given as argument.-withUTF16ToGhcInternal :: Ptr Word8 -- Buffer to store the encoded string in.-                       -> Int       -- Length of the buffer-                       -- Function to fill source buffer.-                       ->  ( CInt       -- Size of available buffer in bytes-                          -> Ptr Word16 -- Temporary source buffer.-                          -> IO CInt    -- Actual length of buffer content.-                           )-                       -> IO Int    -- Returns number of bytes stored in buffer.-withUTF16ToGhcInternal ptr len fn- = do cp <- getCurrentCodePage-      -- Annoyingly the IO system is very UTF-32 oriented and asks for bytes-      -- as buffer reads.  Problem is we don't know how many bytes we'll end up-      -- having as UTF-32 MultiByte encoded UTF-16. So be conservative.  We assume-      -- that a single byte may expand to atmost 1 Word16.  So assume that each-      -- byte does and divide the requested number of bytes by two since each-      -- Word16 encoded wchar may expand to only two Word8 sequences.-      let reqBytes = fromIntegral (len `div` 2)-      allocaArray reqBytes $ \w_ptr -> do-        w_len <- fn (fromIntegral reqBytes) w_ptr-        if w_len == 0-           then return 0 else do-                -- Get required length of encoding-                mbchars' <- failIfZero "withUTF16ToGhcInternal" $-                              wideCharToMultiByte' cp 0 w_ptr-                                                  (fromIntegral w_len) nullPtr-                                                  0 nullPtr nullPtr-                assert (mbchars' <= (fromIntegral len)) $ do-                  -- mbchar' is the length of buffer required-                  mbchars <- failIfZero "withUTF16ToGhcInternal" $-                                wideCharToMultiByte' cp 0 w_ptr-                                                    (fromIntegral w_len) ptr-                                                    mbchars' nullPtr nullPtr-                  return $ fromIntegral mbchars
− GHC/IO/Windows/Handle.hsc 
@@ -1,1015 +0,0 @@-{-# LANGUAGE Trustworthy          #-}-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE NoImplicitPrelude    #-}-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE FlexibleContexts     #-}--- Whether there are identities depends on the platform-{-# OPTIONS_HADDOCK hide #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Windows.Handle--- Copyright   :  (c) The University of Glasgow, 2017--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Raw read/write operations on Windows Handles-----------------------------------------------------------------------------------module GHC.IO.Windows.Handle- ( -- * Basic Types-   NativeHandle(),-   ConsoleHandle(),-   IoHandle(),-   HANDLE,-   Io(),--   -- * Utility functions-   convertHandle,-   toHANDLE,-   fromHANDLE,-   handleToMode,-   isAsynchronous,-   optimizeFileAccess,--   -- * Standard Handles-   stdin,-   stdout,-   stderr,--   -- * File utilities-   openFile,-   openFileAsTemp,-   release- ) where--#include <windows.h>-#include <ntstatus.h>-#include <winnt.h>-##include "windows_cconv.h"---- Can't avoid these semantics leaks, they are base constructs-import Data.Bits ((.|.), (.&.), shiftL)-import Data.Functor ((<$>))-import Data.Typeable--import GHC.Base-import GHC.Enum-import GHC.Num-import GHC.Real-import GHC.List-import GHC.Word (Word8, Word16, Word64)--import GHC.IO hiding (mask)-import GHC.IO.Buffer-import GHC.IO.BufferedIO-import qualified GHC.IO.Device-import GHC.IO.Device (SeekMode(..), IODeviceType(..), IODevice(), devType, setSize)-import GHC.IO.Exception-import GHC.IO.IOMode-import GHC.IO.Windows.Encoding (withGhcInternalToUTF16, withUTF16ToGhcInternal)-import GHC.IO.Windows.Paths (getDevicePath)-import GHC.IO.Handle.Internals (debugIO)-import GHC.IORef-import GHC.Event.Windows (LPOVERLAPPED, withOverlappedEx, IOResult(..))-import Foreign.Ptr-import Foreign.C-import Foreign.Marshal.Array (pokeArray)-import Foreign.Marshal.Alloc (alloca, allocaBytes)-import Foreign.Marshal.Utils (with, fromBool)-import Foreign.Storable (Storable (..))-import qualified GHC.Event.Windows as Mgr--import GHC.Windows (LPVOID, LPDWORD, DWORD, HANDLE, BOOL, LPCTSTR, ULONG, WORD,-                    UCHAR, failIf, iNVALID_HANDLE_VALUE, failWith,-                    failIfFalse_, getLastError)-import Text.Show---- -------------------------------------------------------------------------------- The Windows IO device handles--data NativeHandle-data ConsoleHandle---- | Bit of a Hack, but we don't want every handle to have a cooked entry---   but all copies of the handles for which we do want one need to share---   the same value.---   We can't store it separately because we don't know when the handle will---   be destroyed or invalidated.-data IoHandle a where-  NativeHandle  :: { getNativeHandle  :: HANDLE-                   -- In certain cases we have inherited a handle and the-                   -- handle and it may not have been created for async-                   -- access.  In those case we can't issue a completion-                   -- request as it would never finish and we'd deadlock.-                   , isAsynchronous :: Bool } -> IoHandle NativeHandle-  ConsoleHandle :: { getConsoleHandle :: HANDLE-                   , cookedHandle :: IORef Bool-                   } -> IoHandle ConsoleHandle--type Io a = IoHandle a---- | Convert a ConsoleHandle into a general FileHandle---   This will change which DeviceIO is used.-convertHandle :: Io ConsoleHandle -> Bool -> Io NativeHandle-convertHandle io async-  = let !hwnd = getConsoleHandle io-    in NativeHandle hwnd async---- | @since 4.11.0.0-instance Show (Io NativeHandle) where-  show = show . toHANDLE---- | @since 4.11.0.0-instance Show (Io ConsoleHandle) where-  show = show . getConsoleHandle---- | @since 4.11.0.0-instance GHC.IO.Device.RawIO (Io NativeHandle) where-  read             = hwndRead-  readNonBlocking  = hwndReadNonBlocking-  write            = hwndWrite-  writeNonBlocking = hwndWriteNonBlocking---- | @since 4.11.0.0-instance GHC.IO.Device.RawIO (Io ConsoleHandle) where-  read             = consoleRead True-  readNonBlocking  = consoleReadNonBlocking-  write            = consoleWrite-  writeNonBlocking = consoleWriteNonBlocking---- | Generalize a way to get and create handles.-class (GHC.IO.Device.RawIO a, IODevice a, BufferedIO a, Typeable a)-      => RawHandle a where-  toHANDLE   :: a -> HANDLE-  fromHANDLE :: HANDLE -> a-  isLockable :: a -> Bool-  setCooked  :: a -> Bool -> IO a-  isCooked   :: a -> IO Bool--instance RawHandle (Io NativeHandle) where-  toHANDLE     = getNativeHandle-  -- In order to convert to a native handle we have to check to see-  -- is the handle can be used async or not.-  fromHANDLE   = flip NativeHandle True-  isLockable _ = True-  setCooked    = const . return-  isCooked   _ = return False--instance RawHandle (Io ConsoleHandle) where-  toHANDLE         = getConsoleHandle-  fromHANDLE h     = unsafePerformIO $ ConsoleHandle h <$> newIORef False-  isLockable _     = False-  setCooked  h val =-    do writeIORef (cookedHandle h) val-       return h-  isCooked   h     = readIORef (cookedHandle h)---- -------------------------------------------------------------------------------- The Windows IO device implementation---- | @since 4.11.0.0-instance GHC.IO.Device.IODevice (Io NativeHandle) where-  ready      = handle_ready-  close      = handle_close-  isTerminal = handle_is_console-  isSeekable = handle_is_seekable-  seek       = handle_seek-  tell       = handle_tell-  getSize    = handle_get_size-  setSize    = handle_set_size-  setEcho    = handle_set_echo-  getEcho    = handle_get_echo-  setRaw     = handle_set_buffering-  devType    = handle_dev_type-  dup        = handle_duplicate---- | @since 4.11.0.0-instance GHC.IO.Device.IODevice (Io ConsoleHandle) where-  ready      = handle_ready-  close      = handle_close . flip convertHandle False-  isTerminal = handle_is_console-  isSeekable = handle_is_seekable-  seek       = handle_console_seek-  tell       = handle_console_tell-  getSize    = handle_get_console_size-  setSize    = handle_set_console_size-  setEcho    = handle_set_echo-  getEcho    = handle_get_echo-  setRaw     = console_set_buffering-  devType    = handle_dev_type-  dup        = handle_duplicate---- Default sequential read buffer size.--- for Windows 8k seems to be the optimal--- buffer size.-dEFAULT_BUFFER_SIZE :: Int-dEFAULT_BUFFER_SIZE = 8192---- | @since 4.11.0.0--- See libraries/base/GHC/IO/BufferedIO.hs-instance BufferedIO (Io NativeHandle) where-  newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state-  fillReadBuffer       = readBuf'-  fillReadBuffer0      = readBufNonBlocking-  flushWriteBuffer     = writeBuf'-  flushWriteBuffer0    = writeBufNonBlocking---- | @since 4.11.0.0--- See libraries/base/GHC/IO/BufferedIO.hs-instance BufferedIO (Io ConsoleHandle) where-  newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state-  fillReadBuffer       = readBuf'-  fillReadBuffer0      = readBufNonBlocking-  flushWriteBuffer     = writeBuf'-  flushWriteBuffer0    = writeBufNonBlocking---readBuf' :: RawHandle a => a -> Buffer Word8 -> IO (Int, Buffer Word8)-readBuf' hnd buf = do-  debugIO ("readBuf handle=" ++ show (toHANDLE hnd) ++ " " ++-           summaryBuffer buf ++ "\n")-  (r,buf') <- readBuf hnd buf-  debugIO ("after: " ++ summaryBuffer buf' ++ "\n")-  return (r,buf')--writeBuf' :: RawHandle a => a -> Buffer Word8 -> IO (Buffer Word8)-writeBuf' hnd buf = do-  debugIO ("writeBuf handle=" ++ show (toHANDLE hnd) ++ " " ++-           summaryBuffer buf ++ "\n")-  writeBuf hnd buf---- -------------------------------------------------------------------------------- Standard I/O handles--type StdHandleId  = DWORD--#{enum StdHandleId,- , sTD_INPUT_HANDLE  = STD_INPUT_HANDLE- , sTD_OUTPUT_HANDLE = STD_OUTPUT_HANDLE- , sTD_ERROR_HANDLE  = STD_ERROR_HANDLE-}--getStdHandle :: StdHandleId -> IO HANDLE-getStdHandle hid =-  failIf (== iNVALID_HANDLE_VALUE) "GetStdHandle" $ c_GetStdHandle hid--stdin, stdout, stderr :: Io ConsoleHandle-stdin  = unsafePerformIO $ mkConsoleHandle =<< getStdHandle sTD_INPUT_HANDLE-stdout = unsafePerformIO $ mkConsoleHandle =<< getStdHandle sTD_OUTPUT_HANDLE-stderr = unsafePerformIO $ mkConsoleHandle =<< getStdHandle sTD_ERROR_HANDLE--mkConsoleHandle :: HANDLE -> IO (Io ConsoleHandle)-mkConsoleHandle hwnd-  = do ref <- newIORef False-       return $ ConsoleHandle hwnd ref---- -------------------------------------------------------------------------------- Some console internal types to detect EOF.---- ASCII Ctrl+D (EOT) character.  Typically used by Unix consoles.--- use for cross platform compatibility and to adhere to the ASCII standard.-acCtrlD :: Int-acCtrlD = 0x04--- ASCII Ctrl+Z (SUB) character. Typically used by Windows consoles to denote--- EOT.  Use for compatibility with user expectations.-acCtrlZ :: Int-acCtrlZ = 0x1A---- Mask to use to trigger ReadConsole input processing end.-acEotMask :: ULONG-acEotMask = (1 `shiftL` acCtrlD) .|. (1 `shiftL` acCtrlZ)---- Structure to hold the control character masks-type PCONSOLE_READCONSOLE_CONTROL = Ptr CONSOLE_READCONSOLE_CONTROL-data CONSOLE_READCONSOLE_CONTROL = CONSOLE_READCONSOLE_CONTROL-  { crcNLength           :: ULONG-  , crcNInitialChars     :: ULONG-  , crcDwCtrlWakeupMask  :: ULONG-  , crcDwControlKeyState :: ULONG-  } deriving Show--instance Storable CONSOLE_READCONSOLE_CONTROL where-  sizeOf = const #size CONSOLE_READCONSOLE_CONTROL-  alignment = const #alignment CONSOLE_READCONSOLE_CONTROL-  poke buf crc = do-    (#poke CONSOLE_READCONSOLE_CONTROL, nLength)           buf-        (crcNLength           crc)-    (#poke CONSOLE_READCONSOLE_CONTROL, nInitialChars)     buf-        (crcNInitialChars     crc)-    (#poke CONSOLE_READCONSOLE_CONTROL, dwCtrlWakeupMask)  buf-        (crcDwCtrlWakeupMask  crc)-    (#poke CONSOLE_READCONSOLE_CONTROL, dwControlKeyState) buf-        (crcDwControlKeyState crc)--  peek buf = do-    vNLength           <--      (#peek CONSOLE_READCONSOLE_CONTROL, nLength)           buf-    vNInitialChars     <--      (#peek CONSOLE_READCONSOLE_CONTROL, nInitialChars)     buf-    vDwCtrlWakeupMask  <--      (#peek CONSOLE_READCONSOLE_CONTROL, dwCtrlWakeupMask)  buf-    vDwControlKeyState <--      (#peek CONSOLE_READCONSOLE_CONTROL, dwControlKeyState) buf-    return $ CONSOLE_READCONSOLE_CONTROL {-        crcNLength           = vNLength,-        crcNInitialChars     = vNInitialChars,-        crcDwCtrlWakeupMask  = vDwCtrlWakeupMask,-        crcDwControlKeyState = vDwControlKeyState-      }---- Create CONSOLE_READCONSOLE_CONTROL for breaking on control characters--- specified by acEotMask-eotControl :: CONSOLE_READCONSOLE_CONTROL-eotControl =-  CONSOLE_READCONSOLE_CONTROL-    { crcNLength           = fromIntegral $-                               sizeOf (undefined :: CONSOLE_READCONSOLE_CONTROL)-    , crcNInitialChars     = 0-    , crcDwCtrlWakeupMask  = acEotMask-    , crcDwControlKeyState = 0-    }--type PINPUT_RECORD = Ptr ()--- -------------------------------------------------------------------------------- Foreign imports---foreign import WINDOWS_CCONV safe "windows.h CreateFileW"-    c_CreateFile :: LPCTSTR -> DWORD -> DWORD -> LPSECURITY_ATTRIBUTES-                 -> DWORD -> DWORD -> HANDLE-                 -> IO HANDLE--foreign import WINDOWS_CCONV safe "windows.h SetFileCompletionNotificationModes"-    c_SetFileCompletionNotificationModes :: HANDLE -> UCHAR -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h ReadFile"-    c_ReadFile :: HANDLE -> LPVOID -> DWORD -> LPDWORD -> LPOVERLAPPED-               -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h WriteFile"-    c_WriteFile :: HANDLE -> LPVOID -> DWORD -> LPDWORD -> LPOVERLAPPED-                -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h GetStdHandle"-    c_GetStdHandle :: StdHandleId -> IO HANDLE--foreign import ccall safe "__handle_ready"-    c_handle_ready :: HANDLE -> BOOL -> CInt -> IO CInt--foreign import ccall safe "__is_console"-    c_is_console :: HANDLE -> IO BOOL--foreign import ccall safe "__set_console_buffering"-    c_set_console_buffering :: HANDLE -> BOOL -> IO BOOL--foreign import ccall safe "__set_console_echo"-    c_set_console_echo :: HANDLE -> BOOL -> IO BOOL--foreign import ccall safe "__get_console_echo"-    c_get_console_echo :: HANDLE -> IO BOOL--foreign import ccall safe "__close_handle"-    c_close_handle :: HANDLE -> IO Bool--foreign import ccall safe "__handle_type"-    c_handle_type :: HANDLE -> IO Int--foreign import ccall safe "__set_file_pointer"-  c_set_file_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL--foreign import ccall safe "__get_file_pointer"-  c_get_file_pointer :: HANDLE -> IO CLong--foreign import ccall safe "__get_file_size"-  c_get_file_size :: HANDLE -> IO CLong--foreign import ccall safe "__set_file_size"-  c_set_file_size :: HANDLE -> CLong -> IO BOOL--foreign import ccall safe "__duplicate_handle"-  c_duplicate_handle :: HANDLE -> Ptr HANDLE -> IO BOOL--foreign import ccall safe "__set_console_pointer"-  c_set_console_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL--foreign import ccall safe "__get_console_pointer"-  c_get_console_pointer :: HANDLE -> IO CLong--foreign import ccall safe "__get_console_buffer_size"-  c_get_console_buffer_size :: HANDLE -> IO CLong--foreign import ccall safe "__set_console_buffer_size"-  c_set_console_buffer_size :: HANDLE -> CLong -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h ReadConsoleW"-  c_read_console :: HANDLE -> Ptr Word16 -> DWORD -> Ptr DWORD-                 -> PCONSOLE_READCONSOLE_CONTROL -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h WriteConsoleW"-  c_write_console :: HANDLE -> Ptr Word16 -> DWORD -> Ptr DWORD -> Ptr ()-                  -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h ReadConsoleInputW"-  c_read_console_input :: HANDLE -> PINPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL--foreign import WINDOWS_CCONV safe "windows.h GetNumberOfConsoleInputEvents"-  c_get_num_console_inputs :: HANDLE -> LPDWORD -> IO BOOL--type LPSECURITY_ATTRIBUTES = LPVOID---- -------------------------------------------------------------------------------- Reading and Writing---- For this to actually block, the file handle must have--- been created with FILE_FLAG_OVERLAPPED not set. As an implementation note I--- am choosing never to let this block. But this can be easily accomplished by--- a getOverlappedResult call with True-hwndRead :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int-hwndRead hwnd ptr offset bytes = do-  mngr <- Mgr.getSystemManager-  fmap fromIntegral $ Mgr.withException "hwndRead" $-     withOverlappedEx mngr "hwndRead" (toHANDLE hwnd) (isAsynchronous hwnd)-                      offset (startCB ptr) completionCB-  where-    startCB outBuf lpOverlapped = do-      debugIO ":: hwndRead"-      -- See Note [ReadFile/WriteFile].-      ret <- c_ReadFile (toHANDLE hwnd) (castPtr outBuf)-                        (fromIntegral bytes) nullPtr lpOverlapped-      return $ Mgr.CbNone ret--    completionCB err dwBytes-      | err == #{const ERROR_SUCCESS}       = Mgr.ioSuccess $ fromIntegral dwBytes-      | err == #{const ERROR_HANDLE_EOF}    = Mgr.ioSuccess 0-      | err == #{const STATUS_END_OF_FILE}  = Mgr.ioSuccess 0-      | err == #{const ERROR_BROKEN_PIPE}   = Mgr.ioSuccess 0-      | err == #{const STATUS_PIPE_BROKEN}  = Mgr.ioSuccess 0-      | err == #{const ERROR_NO_MORE_ITEMS} = Mgr.ioSuccess $ fromIntegral dwBytes-      | err == #{const ERROR_MORE_DATA}     = Mgr.ioSuccess $ fromIntegral dwBytes-      | otherwise                           = Mgr.ioFailed err---- In WinIO we'll never block in the FFI call, so this call is equivalent to--- hwndRead,  Though we may revisit this when implementing sockets and pipes.--- It still won't block, but may set up extra book keeping so threadWait and--- threadWrite may work.-hwndReadNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int-                    -> IO (Maybe Int)-hwndReadNonBlocking hwnd ptr offset bytes-  = do mngr <- Mgr.getSystemManager-       val <- withOverlappedEx mngr "hwndReadNonBlocking" (toHANDLE hwnd)-                               (isAsynchronous hwnd) offset (startCB ptr)-                               completionCB-       return $ ioValue val-  where-    startCB inputBuf lpOverlapped = do-      debugIO ":: hwndReadNonBlocking"-      -- See Note [ReadFile/WriteFile].-      ret <- c_ReadFile (toHANDLE hwnd) (castPtr inputBuf)-                        (fromIntegral bytes) nullPtr lpOverlapped-      return $ Mgr.CbNone ret--    completionCB err dwBytes-      | err == #{const ERROR_SUCCESS}       = Mgr.ioSuccess $ Just $! fromIntegral dwBytes-      | err == #{const ERROR_HANDLE_EOF}    = Mgr.ioSuccess Nothing-      | err == #{const STATUS_END_OF_FILE}  = Mgr.ioSuccess Nothing-      | err == #{const ERROR_BROKEN_PIPE}   = Mgr.ioSuccess Nothing-      | err == #{const STATUS_PIPE_BROKEN}  = Mgr.ioSuccess Nothing-      | err == #{const ERROR_NO_MORE_ITEMS} = Mgr.ioSuccess Nothing-      | err == #{const ERROR_MORE_DATA}     = Mgr.ioSuccess $ Just $! fromIntegral dwBytes-      | otherwise                           = Mgr.ioFailedAny err--hwndWrite :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO ()-hwndWrite hwnd ptr offset bytes-  = do mngr <- Mgr.getSystemManager-       _ <- Mgr.withException "hwndWrite" $-          withOverlappedEx mngr "hwndWrite" (toHANDLE hwnd)-                           (isAsynchronous hwnd) offset (startCB ptr)-                           completionCB-       return ()-  where-    startCB outBuf lpOverlapped = do-      debugIO ":: hwndWrite"-      -- See Note [ReadFile/WriteFile].-      ret <- c_WriteFile (toHANDLE hwnd) (castPtr outBuf)-                         (fromIntegral bytes) nullPtr lpOverlapped-      return $ Mgr.CbNone ret--    completionCB err dwBytes-        | err == #{const ERROR_SUCCESS}  =   Mgr.ioSuccess $ fromIntegral dwBytes-        | err == #{const ERROR_HANDLE_EOF} = Mgr.ioSuccess $ fromIntegral dwBytes-        | otherwise                        = Mgr.ioFailed err--hwndWriteNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int-hwndWriteNonBlocking hwnd ptr offset bytes-  = do mngr <- Mgr.getSystemManager-       val <- withOverlappedEx mngr "hwndReadNonBlocking" (toHANDLE hwnd)-                               (isAsynchronous hwnd) offset (startCB ptr)-                               completionCB-       return $ fromIntegral $ ioValue val-  where-    startCB :: Ptr a -> LPOVERLAPPED -> IO (Mgr.CbResult a1)-    startCB outBuf lpOverlapped = do-      debugIO ":: hwndWriteNonBlocking"-      -- See Note [ReadFile/WriteFile].-      ret <- c_WriteFile (toHANDLE hwnd) (castPtr outBuf)-                         (fromIntegral bytes) nullPtr lpOverlapped-      return $ Mgr.CbNone ret--    completionCB err dwBytes-        | err == #{const ERROR_SUCCESS}    = Mgr.ioSuccess $ fromIntegral dwBytes-        | err == #{const ERROR_HANDLE_EOF} = Mgr.ioSuccess $ fromIntegral dwBytes-        | otherwise                        = Mgr.ioFailed err---- Note [ReadFile/WriteFile]--- The results of these functions are somewhat different when working in an--- asynchronous manner. The returning bool has two meaning.------ True: The operation is done and was completed synchronously.  This is---       possible because of the optimization flags we enable.  In this case---       there won't be a completion event for this call and so we shouldn't---       queue one up. If we do this request will never terminate.  It's also---       safe to free the OVERLAPPED structure immediately.------ False: Only indicates that the operation was not completed synchronously, a---        call to GetLastError () is needed to find out the actual status. If---        the result is ERROR_IO_PENDING then the operation has been queued on---        the completion port and we should proceed asynchronously.  Any other---        state is usually an indication that the call failed.------ NB. reading an EOF will result in ERROR_HANDLE_EOF or STATUS_END_OF_FILE--- during the checking of the completion results.  We need to check for these--- so we don't incorrectly fail.---consoleWrite :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO ()-consoleWrite hwnd ptr _offset bytes-  = alloca $ \res ->-      do failIfFalse_ "GHC.IO.Handle.consoleWrite" $ do-           debugIO ":: consoleWrite"-           withGhcInternalToUTF16 ptr bytes $ \(w_ptr, w_len) -> do-              success <- c_write_console (toHANDLE hwnd) w_ptr-                                         (fromIntegral w_len) res nullPtr-              if not success-                 then return False-                 else do val <- fromIntegral <$> peek res-                         return $ val == w_len--consoleWriteNonBlocking :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int-consoleWriteNonBlocking hwnd ptr _offset bytes-  = alloca $ \res ->-      do failIfFalse_ "GHC.IO.Handle.consoleWriteNonBlocking" $ do-            debugIO ":: consoleWriteNonBlocking"-            withGhcInternalToUTF16 ptr bytes $ \(w_ptr, w_len) -> do-              c_write_console (toHANDLE hwnd) w_ptr (fromIntegral w_len)-                              res nullPtr-         val <- fromIntegral <$> peek res-         return val--consoleRead :: Bool -> Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int-consoleRead blocking hwnd ptr _offset bytes-  = alloca $ \res -> do-      cooked <- isCooked hwnd-      -- Cooked input must be handled differently when the STD handles are-      -- attached to a real console handle.  For File based handles we can't do-      -- proper cooked inputs, but since the actions are async you would get-      -- results as soon as available.-      ---      -- For console handles We have to use a lower level API then ReadConsole,-      -- namely we must use ReadConsoleInput which requires us to process-      -- all console message manually.-      ---      -- Do note that MSYS2 shells such as bash don't attach to a real handle,-      -- and instead have by default a pipe/file based std handles.  Which-      -- means the cooked behaviour is best when used in a native Windows-      -- terminal such as cmd, powershell or ConEmu.-      case cooked || not blocking of-        False -> withUTF16ToGhcInternal ptr bytes $ \reqBytes w_ptr ->  do-          debugIO "consoleRead :: un-cooked I/O read."-          -- eotControl allows us to handle control characters like EOL-          -- without needing a newline, which would sort of defeat the point-          -- of an EOL.-          res_code <- with eotControl $ \p_eotControl ->-                c_read_console (toHANDLE hwnd) w_ptr (fromIntegral reqBytes) res-                               p_eotControl--          -- Restore a quirk of the POSIX read call, which only returns a fail-          -- when the handle is invalid, e.g. closed or not a handle.  It how--          -- ever returns 0 when the handle is valid but unreadable, such as-          -- passing a handle with no GENERIC_READ permission, like /dev/null-          err <- getLastError-          when (not res_code) $-            case () of-             _ | err == #{const ERROR_INVALID_FUNCTION} -> return ()-               | otherwise -> failWith "GHC.IO.Handle.consoleRead" err-          b_read <- fromIntegral <$> peek res-          if b_read /= 1-              then return b_read-              else do w_first <- peekElemOff w_ptr 0-                      case () of-                        -- Handle Ctrl+Z which is the actual EOL sequence on-                        -- windows, but also handle Ctrl+D which is what the-                        -- ASCII standard defines as EOL.-                        _ | w_first == fromIntegral acCtrlD -> return 0-                          | w_first == fromIntegral acCtrlZ -> return 0-                          | otherwise                       -> return b_read-        True -> do-          debugIO "consoleRead :: cooked I/O read."-          -- Input is cooked, don't wait till a line return and consume all-          -- characters as they are.  Technically this function can handle any-          -- console event.  Including mouse, window and virtual key events-          -- but for now I'm only interested in key presses.-          let entries = fromIntegral $ bytes `div` (#size INPUT_RECORD)-          allocaBytes entries $ \p_inputs ->-            maybeReadEvent p_inputs entries res ptr--          -- Check to see if we have been explicitly asked to do a non-blocking-          -- I/O, and if we were, make sure that if we didn't have any console-          -- events that we don't block.-    where maybeReadEvent p_inputs entries res w_ptr =-            case (not blocking) of-              True -> do-                avail <- with (0 :: DWORD) $ \num_events_ptr -> do-                  failIfFalse_ "GHC.IO.Handle.consoleRead [non-blocking]" $-                    c_get_num_console_inputs (toHANDLE hwnd) num_events_ptr-                  peek num_events_ptr-                debugIO $ "consoleRead [avail] :: " ++ show avail-                if avail > 0-                  then readEvent p_inputs entries res w_ptr-                  else return 0-              False -> readEvent p_inputs entries res w_ptr--          -- Unconditionally issue the first read, but conditionally-          -- do the recursion.-          readEvent p_inputs entries res w_ptr = do-            failIfFalse_ "GHC.IO.Handle.consoleRead" $-              c_read_console_input (toHANDLE hwnd) p_inputs-                                   (fromIntegral entries) res--            b_read <- fromIntegral <$> peek res-            read <- cobble b_read w_ptr p_inputs-            debugIO $ "readEvent: =" ++ show read-            if read > 0-               then return $ fromIntegral read-               else maybeReadEvent p_inputs entries res w_ptr--          -- Dereference and read console input records.  We only read the bare-          -- minimum required to know which key/sequences were pressed.  To do-          -- this and prevent having to fully port the PINPUT_RECORD structure-          -- in Haskell we use some GCC builtins to find the correct offsets.-          cobble :: Int -> Ptr Word8 -> PINPUT_RECORD -> IO Int-          cobble 0 _ _ = do debugIO "cobble: done."-                            return 0-          cobble n w_ptr p_inputs =-            do eventType <- peekByteOff p_inputs 0 :: IO WORD-               debugIO $ "cobble: Length=" ++ show n-               debugIO $ "cobble: Type=" ++ show eventType-               let ni_offset      = #size INPUT_RECORD-               let event          = #{const __builtin_offsetof (INPUT_RECORD, Event)}-               let char_offset    = event + #{const __builtin_offsetof (KEY_EVENT_RECORD, uChar)}-               let btnDown_offset = event + #{const __builtin_offsetof (KEY_EVENT_RECORD, bKeyDown)}-               let repeat_offset  = event + #{const __builtin_offsetof (KEY_EVENT_RECORD, wRepeatCount)}-               let n'             = n - 1-               let p_inputs'      = p_inputs `plusPtr` ni_offset-               btnDown  <- peekByteOff p_inputs btnDown_offset-               repeated <- fromIntegral <$> (peekByteOff p_inputs repeat_offset :: IO WORD)-               debugIO $ "cobble: BtnDown=" ++ show btnDown-               -- Handle the key only on button down and not on button up.-               if eventType == #{const KEY_EVENT} && btnDown-                  then do debugIO $ "cobble: read-char."-                          char <- peekByteOff p_inputs char_offset-                          let w_ptr' = w_ptr `plusPtr` 1-                          debugIO $ "cobble: offset - " ++ show char_offset-                          debugIO $ "cobble: show > " ++ show char-                          debugIO $ "cobble: repeat: " ++ show repeated-                          -- The documentation here is rather subtle, but-                          -- according to MSDN the uWChar being provided here-                          -- has been "translated".  What this actually means-                          -- is that the surrogate pairs have already been-                          -- translated into byte sequences.  That is, despite-                          -- the Word16 storage type, it's actually a byte-                          -- stream.  This means we shouldn't try to decode-                          -- to UTF-8 again since we'd end up incorrectly-                          -- interpreting two bytes as an extended unicode-                          -- character.-                          pokeArray w_ptr $ replicate repeated char-                          (+repeated) <$> cobble n' w_ptr' p_inputs'-                  else do debugIO $ "cobble: skip event."-                          cobble n' w_ptr p_inputs'---consoleReadNonBlocking :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int-                       -> IO (Maybe Int)-consoleReadNonBlocking hwnd ptr offset bytes-  = Just <$> consoleRead False hwnd ptr offset bytes---- -------------------------------------------------------------------------------- Operations on file handles--handle_ready :: RawHandle a => a -> Bool -> Int -> IO Bool-handle_ready hwnd write msecs = do-  r <- throwErrnoIfMinus1Retry "GHC.IO.Windows.Handle.handle_ready" $-          c_handle_ready (toHANDLE hwnd) write (fromIntegral msecs)-  return (toEnum (fromIntegral r))--handle_is_console :: RawHandle a => a -> IO Bool-handle_is_console = c_is_console . toHANDLE--handle_close :: RawHandle a => a -> IO ()-handle_close h = do release h-                    failIfFalse_ "handle_close" $ c_close_handle (toHANDLE h)--handle_dev_type :: RawHandle a => a -> IO IODeviceType-handle_dev_type hwnd = do _type <- c_handle_type $ toHANDLE hwnd-                          return $ case _type of-                                     _ | _type == 3 -> Stream-                                       | _type == 5 -> RawDevice-                                       | otherwise  -> RegularFile--handle_is_seekable :: RawHandle a => a -> IO Bool-handle_is_seekable hwnd = do-  t <- handle_dev_type hwnd-  return (t == RegularFile || t == RawDevice)--handle_seek :: RawHandle a => a -> SeekMode -> Integer -> IO Integer-handle_seek hwnd mode off =-  with 0 $ \off_rel -> do-    failIfFalse_ "GHC.IO.Handle.handle_seek" $-        c_set_file_pointer (toHANDLE hwnd) (fromIntegral off) seektype off_rel-    fromIntegral <$> peek off_rel- where-    seektype :: DWORD-    seektype = case mode of-                   AbsoluteSeek -> #{const FILE_BEGIN}-                   RelativeSeek -> #{const FILE_CURRENT}-                   SeekFromEnd  -> #{const FILE_END}--handle_tell :: RawHandle a => a -> IO Integer-handle_tell hwnd =-   fromIntegral `fmap`-      (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_tell" $-          c_get_file_pointer (toHANDLE hwnd))--handle_set_size :: RawHandle a => a -> Integer -> IO ()-handle_set_size hwnd size =-  failIfFalse_ "GHC.IO.Handle.handle_set_size" $-      c_set_file_size (toHANDLE hwnd) (fromIntegral size)--handle_get_size :: RawHandle a => a -> IO Integer-handle_get_size hwnd =-   fromIntegral `fmap`-      (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_set_size" $-          c_get_file_size (toHANDLE hwnd))--handle_set_echo :: RawHandle a => a -> Bool -> IO ()-handle_set_echo hwnd value =-  failIfFalse_ "GHC.IO.Handle.handle_set_echo" $-      c_set_console_echo (toHANDLE hwnd) value--handle_get_echo :: RawHandle a => a -> IO Bool-handle_get_echo = c_get_console_echo . toHANDLE--handle_duplicate :: RawHandle a => a -> IO a-handle_duplicate hwnd = alloca $ \ptr -> do-  failIfFalse_ "GHC.IO.Handle.handle_duplicate" $-      c_duplicate_handle (toHANDLE hwnd) ptr-  fromHANDLE <$> peek ptr--console_set_buffering :: Io ConsoleHandle -> Bool -> IO ()-console_set_buffering hwnd value = setCooked hwnd value >> return ()--handle_set_buffering :: RawHandle a => a -> Bool -> IO ()-handle_set_buffering hwnd value =-  failIfFalse_ "GHC.IO.Handle.handle_set_buffering" $-      c_set_console_buffering (toHANDLE hwnd) value--handle_console_seek :: RawHandle a => a -> SeekMode -> Integer -> IO Integer-handle_console_seek hwnd mode off =-  with 0 $ \loc_ptr -> do-    failIfFalse_ "GHC.IO.Handle.handle_console_seek" $-      c_set_console_pointer (toHANDLE hwnd) (fromIntegral off) seektype loc_ptr-    fromIntegral <$> peek loc_ptr- where-    seektype :: DWORD-    seektype = case mode of-                 AbsoluteSeek -> #{const FILE_BEGIN}-                 RelativeSeek -> #{const FILE_CURRENT}-                 SeekFromEnd  -> #{const FILE_END}--handle_console_tell :: RawHandle a => a -> IO Integer-handle_console_tell hwnd =-   fromIntegral `fmap`-      (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_console_tell" $-          c_get_console_pointer (toHANDLE hwnd))--handle_set_console_size :: RawHandle a => a -> Integer -> IO ()-handle_set_console_size hwnd size =-  failIfFalse_ "GHC.IO.Handle.handle_set_console_size" $-      c_set_console_buffer_size (toHANDLE hwnd) (fromIntegral size)--handle_get_console_size :: RawHandle a => a -> IO Integer-handle_get_console_size hwnd =-   fromIntegral `fmap`-      (throwErrnoIfMinus1Retry "GHC.IO.Handle.handle_get_console_size" $-          c_get_console_buffer_size (toHANDLE hwnd))---- -------------------------------------------------------------------------------- opening files---- | Describes if and which temp file flags to use.-data TempFileOptions = NoTemp | TempNonExcl | TempExcl deriving Eq---- | Open a file and make an 'NativeHandle' for it.  Truncates the file to zero--- size when the `IOMode` is `WriteMode`.-openFile-  :: FilePath -- ^ file to open-  -> IOMode   -- ^ mode in which to open the file-  -> Bool     -- ^ open the file in non-blocking mode?-  -> IO (Io NativeHandle, IODeviceType)-openFile filepath iomode non_blocking = openFile' filepath iomode non_blocking NoTemp---- | Open a file as a temporary file and make an 'NativeHandle' for it.--- Truncates the file to zero size when the `IOMode` is `WriteMode`.-openFileAsTemp-  :: FilePath -- ^ file to open-  -> Bool     -- ^ open the file in non-blocking mode?-  -> Bool     -- ^ Exclusive mode-  -> IO (Io NativeHandle, IODeviceType)-openFileAsTemp filepath non_blocking excl-  = openFile' filepath ReadWriteMode non_blocking (if excl then TempExcl else TempNonExcl)---- | Open a file and make an 'NativeHandle' for it.  Truncates the file to zero--- size when the `IOMode` is `WriteMode`.-openFile'-  :: FilePath -- ^ file to open-  -> IOMode   -- ^ mode in which to open the file-  -> Bool     -- ^ open the file in non-blocking mode?-  -> TempFileOptions-  -> IO (Io NativeHandle, IODeviceType)-openFile' filepath iomode non_blocking tmp_opts =-   do devicepath <- getDevicePath filepath-      h <- createFile devicepath-      -- Attach the handle to the I/O manager's CompletionPort.  This allows the-      -- I/O manager to service requests for this Handle.-      Mgr.associateHandle' h-      let hwnd = fromHANDLE h-      _type <- devType hwnd--      -- Use the rts to enforce any file locking we may need.-      let write_lock = iomode /= ReadMode--      case _type of-        -- Regular files need to be locked.-        -- See also Note [RTS File locking]-        RegularFile -> do-          optimizeFileAccess h -- Set a few optimization flags on file handles.-          (unique_dev, unique_ino) <- getUniqueFileInfo hwnd-          r <- lockFile (fromIntegral $ ptrToWordPtr h) unique_dev unique_ino-                        (fromBool write_lock)-          when (r == -1)  $-               ioException (IOError Nothing ResourceBusy "openFile"-                                  "file is locked" Nothing Nothing)--        -- I don't see a reason for blocking directories.  So unlike the FD-        -- implementation I'll allow it.-        _ -> return ()--      -- We want to truncate() if this is an open in WriteMode, but only-      -- if the target is a RegularFile.  but TRUNCATE_EXISTING would fail if-      -- the file didn't exit.  So just set the size afterwards.-      when (iomode == WriteMode && _type == RegularFile) $-        setSize hwnd 0--      return (hwnd, _type)-        where-          flagIf p f2-            | p         = f2-            | otherwise = 0-          -- We have to use in-process locking (e.g. use the locking mechanism-          -- in the rts) so we're consistent with the linux behavior and the-          -- rts knows about the lock.  See #4363 for more.-          file_share_mode =  #{const FILE_SHARE_READ}-                         .|. #{const FILE_SHARE_DELETE}-                         -- Don't support shared writing for temp files.-                         .|. (flagIf (tmp_opts == NoTemp)-                                     #{const FILE_SHARE_WRITE})--          file_access_mode =-            case iomode of-              ReadMode      -> #{const GENERIC_READ}-              WriteMode     -> #{const GENERIC_WRITE}-              ReadWriteMode -> #{const GENERIC_READ}-                            .|. #{const GENERIC_WRITE}-              AppendMode    -> #{const GENERIC_WRITE}-                            .|. #{const FILE_APPEND_DATA}--          file_open_mode =-            case iomode of-              ReadMode      -> #{const OPEN_EXISTING} -- O_RDONLY-              WriteMode     -> #{const OPEN_ALWAYS}   -- O_CREAT | O_WRONLY | O_TRUNC-              ReadWriteMode ->-                case tmp_opts of-                  NoTemp    -> #{const OPEN_ALWAYS}   -- O_CREAT | O_RDWR-                  TempNonExcl ->  #{const CREATE_ALWAYS} -- O_CREAT | O_RDWR-                  TempExcl  -> #{const CREATE_NEW}    -- O_CREAT | O_RDWR | O_EXCL-              AppendMode    -> #{const OPEN_ALWAYS}   -- O_APPEND--          file_create_flags =-            if non_blocking-               -- On Windows, the choice of whether an operation completes-               -- asynchronously or not depends on how the Handle was created-               -- and not on the operation called.  As in, the behaviour of-               -- ReadFile and WriteFile depends on the flags used to open the-               -- handle.   For WinIO we always use FILE_FLAG_OVERLAPPED, which-               -- means we always issue asynchronous file operation using an-               -- OVERLAPPED structure.  All blocking, if required must be done-               -- on the Haskell side by using existing mechanisms such as MVar-               -- or IOPorts.-               then #{const FILE_FLAG_OVERLAPPED}-                    -- I believe most haskell programs do sequential scans, so-                    -- optimize for the common case.  Though ideally, this would-                    -- be parameterized by openFile.  This will absolutely trash-                    -- the cache on reverse scans.-                    ---                    -- TODO: make a parameter to openFile and specify only for-                    -- operations we know are sequential.  This parameter should-                    -- be usable by madvise too.-                    .|. #{const FILE_FLAG_SEQUENTIAL_SCAN}-                    .|. (flagIf (tmp_opts /= NoTemp)-                                -- Hold data in cache for as long as possible-                                #{const FILE_ATTRIBUTE_TEMPORARY} )-               else #{const FILE_ATTRIBUTE_NORMAL}-                    .|. (flagIf (tmp_opts /= NoTemp)-                                -- Hold data in cache for as long as possible-                                #{const FILE_ATTRIBUTE_TEMPORARY} )--          createFile devicepath =-            withCWString devicepath $ \fp ->-                failIf (== iNVALID_HANDLE_VALUE) "CreateFile" $-                      c_CreateFile fp file_access_mode-                                      file_share_mode-                                      nullPtr-                                      file_open_mode-                                      file_create_flags-                                      nullPtr---- Tell the OS that we support skipping the request Queue if the--- IRQ can be handled immediately, e.g. if the data is in the cache.-optimizeFileAccess :: HANDLE -> IO ()-optimizeFileAccess handle =-    failIfFalse_ "SetFileCompletionNotificationModes"  $-      c_SetFileCompletionNotificationModes handle-          (    #{const FILE_SKIP_COMPLETION_PORT_ON_SUCCESS}-            .|. #{const FILE_SKIP_SET_EVENT_ON_HANDLE})---- Reconstruct an I/O mode from an open HANDLE-handleToMode :: HANDLE -> IO IOMode-handleToMode hwnd = do-  mask <- c_get_handle_access_mask hwnd-  let hasFlag flag = (flag .&. mask) == flag-  case () of-    () | hasFlag (#{const FILE_APPEND_DATA})                        -> return AppendMode-       | hasFlag (#{const GENERIC_WRITE} .|. #{const GENERIC_READ}) -> return ReadWriteMode-       | hasFlag (#{const GENERIC_READ})                            -> return ReadMode-       | hasFlag (#{const GENERIC_WRITE})                           -> return WriteMode-       | otherwise -> error "unknown access mask in handleToMode."--foreign import ccall unsafe "__get_handle_access_mask"-  c_get_handle_access_mask :: HANDLE -> IO DWORD--release :: RawHandle a => a -> IO ()-release h = if isLockable h-               then do let handle = fromIntegral $ ptrToWordPtr $ toHANDLE h-                       _ <- unlockFile handle-                       return ()-               else return ()---- -------------------------------------------------------------------------------- Locking/unlocking--foreign import ccall unsafe "lockFile"-  lockFile :: CUIntPtr -> Word64 -> Word64 -> CInt -> IO CInt--foreign import ccall unsafe "unlockFile"-  unlockFile :: CUIntPtr -> IO CInt---- | Returns -1 on error. Otherwise writes two values representing--- the file into the given ptrs.-foreign import ccall unsafe "get_unique_file_info_hwnd"-  c_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()---- | getUniqueFileInfo assumes the C call to getUniqueFileInfo--- succeeds.-getUniqueFileInfo :: RawHandle a => a -> IO (Word64, Word64)-getUniqueFileInfo handle = do-  with 0 $ \devptr -> do-    with 0 $ \inoptr -> do-      c_getUniqueFileInfo (toHANDLE handle) devptr inoptr-      liftM2 (,) (peek devptr) (peek inoptr)
− GHC/IO/Windows/Paths.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE Trustworthy          #-}-{-# LANGUAGE NoImplicitPrelude    #-}-{-# LANGUAGE CPP                  #-}--- Whether there are identities depends on the platform-{-# OPTIONS_HADDOCK hide #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IO.Windows.Paths--- Copyright   :  (c) The University of Glasgow, 2017--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Windows FilePath handling utility for GHC code.-----------------------------------------------------------------------------------module GHC.IO.Windows.Paths- (getDevicePath- ) where--#include "windows_cconv.h"--import GHC.Base-import GHC.IO--import Foreign.C.String-import Foreign.Marshal.Alloc (free)--foreign import ccall safe "__hs_create_device_name"-    c_GetDevicePath :: CWString -> IO CWString---- | This function converts Windows paths between namespaces. More specifically--- It converts an explorer style path into a NT or Win32 namespace.--- This has several caveats but they are caviats that are native to Windows and--- not POSIX. See--- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx.--- Anything else such as raw device paths we leave untouched.  The main benefit--- of doing any of this is that we can break the MAX_PATH restriction and also--- access raw handles that we couldn't before.-getDevicePath :: FilePath -> IO FilePath-getDevicePath path-  = do str <- withCWString path c_GetDevicePath-       newPath <- peekCWString str-       free str-       return newPath
− GHC/IOArray.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, RoleAnnotations #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IOArray--- Copyright   :  (c) The University of Glasgow 2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The IOArray type-----------------------------------------------------------------------------------module GHC.IOArray (-        IOArray(..),-        newIOArray, unsafeReadIOArray, unsafeWriteIOArray,-        readIOArray, writeIOArray,-        boundsIOArray-    ) where--import GHC.Base-import GHC.IO-import GHC.Arr---- ------------------------------------------------------------------------------ | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad.--- The type arguments are as follows:------  * @i@: the index type of the array (should be an instance of 'Ix')------  * @e@: the element type of the array.--------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---- explicit instance because Haddock can't figure out a derived one--- | @since 4.1.0.0-instance Eq (IOArray i e) where-  IOArray x == IOArray y = x == y---- |Build a new 'IOArray'-newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)-{-# INLINE newIOArray #-}-newIOArray lu initial  = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)}---- | Read a value from an 'IOArray'-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 :: IOArray i e -> Int -> e -> IO ()-{-# INLINE unsafeWriteIOArray #-}-unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e)---- | Read a value from an 'IOArray'-readIOArray  :: Ix i => IOArray i e -> i -> IO e-readIOArray (IOArray marr) i = stToIO (readSTArray marr i)---- | Write a new value into an 'IOArray'-writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()-writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)--{-# INLINE boundsIOArray #-}-boundsIOArray :: IOArray i e -> (i,i)-boundsIOArray (IOArray marr) = boundsSTArray marr-
− GHC/IOPort.hs 
@@ -1,122 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK hide #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IOPort--- Copyright   :  (c) Tamar Christina 2019--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The IOPort type. This is a facility used by the Windows IO subsystem.--- We have strict rules with an I/O Port:--- * writing more than once is an error--- * reading more than once is an error------ It gives us the ability to have one thread to block, wait for a result from--- another thread and then being woken up. *Nothing* more.------ This type is very much GHC internal. It might be changed or removed without--- notice in future releases.-----------------------------------------------------------------------------------module GHC.IOPort (-        -- * IOPorts-          IOPort(..)-        , newIOPort-        , newEmptyIOPort-        , readIOPort-        , writeIOPort-        , doubleReadException-    ) where--import GHC.Base-import GHC.Exception-import Text.Show--data IOPortException = IOPortException deriving Show--instance Exception IOPortException where-    displayException IOPortException = "IOPortException"---doubleReadException :: SomeException-doubleReadException = toException IOPortException--data IOPort a = IOPort (IOPort# RealWorld a)-{- ^-An 'IOPort' is a synchronising variable, used-for communication between concurrent threads, where one of the threads is-controlled by an external state. e.g. by an I/O action that is serviced by the-runtime.  It can be thought of as a box, which may be empty or full.--It is mostly similar to the behavior of 'Control.Concurrent.MVar.MVar'-except 'writeIOPort' doesn't block if the variable is full and the GC-won't forcibly release the lock if it thinks-there's a deadlock.--The properties of IOPorts are:-* Writing to an empty IOPort will not block.-* Writing to an full  IOPort will not block. It might throw an exception.-* Reading from an IOPort for the second time might throw an exception.-* Reading from a full IOPort will not block, return the value and empty the port.-* Reading from an empty IOPort will block until a write.-* Reusing an IOPort (that is, reading or writing twice) is not supported-  and might throw an exception. Even if reads and writes are-  interleaved.--This type is very much GHC internal. It might be changed or removed without-notice in future releases.---}---- | @since 4.1.0.0-instance Eq (IOPort a) where-        (IOPort ioport1#) == (IOPort ioport2#) =-            isTrue# (sameIOPort# ioport1# ioport2#)------ |Create an 'IOPort' which is initially empty.-newEmptyIOPort  :: IO (IOPort a)-newEmptyIOPort = IO $ \ s# ->-    case newIOPort# s# of-         (# s2#, svar# #) -> (# s2#, IOPort svar# #)---- |Create an 'IOPort' which contains the supplied value.-newIOPort :: a -> IO (IOPort a)-newIOPort value =-    newEmptyIOPort        >>= \ ioport ->-    writeIOPort ioport value  >>-    return ioport---- |Atomically read the the contents of the 'IOPort'.  If the 'IOPort' is--- currently empty, 'readIOPort' will wait until it is full.  After a--- 'readIOPort', the 'IOPort' is left empty.------ There is one important property of 'readIOPort':------   * Only a single threads can be blocked on an 'IOPort'.----readIOPort :: IOPort a -> IO a-readIOPort (IOPort ioport#) = IO $ \ s# -> readIOPort# ioport# s#---- |Put a value into an 'IOPort'.  If the 'IOPort' is currently full,--- 'writeIOPort' will throw an exception.------ There is one important property of 'writeIOPort':------   * Only a single thread can be blocked on an 'IOPort'.----writeIOPort  :: IOPort a -> a -> IO Bool-writeIOPort (IOPort ioport#) x = IO $ \ s# ->-    case writeIOPort# ioport# x s# of-        (# s, 0# #) -> (# s, False #)-        (# s, _  #) -> (# s, True #)-
− GHC/IORef.hs 
@@ -1,170 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.IORef--- Copyright   :  (c) The University of Glasgow 2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The IORef type-----------------------------------------------------------------------------------module GHC.IORef (-        IORef(..),-        newIORef, readIORef, writeIORef, atomicModifyIORef2Lazy,-        atomicModifyIORef2, atomicModifyIORefLazy_, atomicModifyIORef'_,-        atomicModifyIORefP, atomicSwapIORef, atomicModifyIORef'-    ) where--import GHC.Base-import GHC.STRef-import GHC.IO---- ------------------------------------------------------------------------------ IORefs---- |A mutable variable in the 'IO' monad-newtype IORef a = IORef (STRef RealWorld a)-  deriving Eq-  -- ^ Pointer equality.-  ---  -- @since 4.0.0.0---- |Build a new 'IORef'-newIORef    :: a -> IO (IORef a)-newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)---- |Read the value of an 'IORef'-readIORef   :: IORef a -> IO a-readIORef  (IORef var) = stToIO (readSTRef var)---- |Write a new value into an 'IORef'-writeIORef  :: IORef a -> a -> IO ()-writeIORef (IORef var) v = stToIO (writeSTRef var v)---- Atomically apply a function to the contents of an 'IORef',--- installing its first component in the 'IORef' and returning--- the old contents and the result of applying the function.--- The result of the function application (the pair) is not forced.--- As a result, this can lead to memory leaks. It is generally better--- to use 'atomicModifyIORef2'.-atomicModifyIORef2Lazy :: IORef a -> (a -> (a,b)) -> IO (a, (a, b))-atomicModifyIORef2Lazy (IORef (STRef r#)) f =-  IO (\s -> case atomicModifyMutVar2# r# f s of-              (# s', old, res #) -> (# s', (old, res) #))---- Atomically apply a function to the contents of an 'IORef',--- installing its first component in the 'IORef' and returning--- the old contents and the result of applying the function.--- The result of the function application (the pair) is forced,--- but neither of its components is.-atomicModifyIORef2 :: IORef a -> (a -> (a,b)) -> IO (a, (a, b))-atomicModifyIORef2 ref f = do-  r@(_old, (_new, _res)) <- atomicModifyIORef2Lazy ref f-  return r---- | A version of 'Data.IORef.atomicModifyIORef' that forces--- the (pair) result of the function.-atomicModifyIORefP :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORefP ref f = do-  (_old, (_,r)) <- atomicModifyIORef2 ref f-  pure r---- | Atomically apply a function to the contents of an--- 'IORef' and return the old and new values. The result--- of the function is not forced. As this can lead to a--- memory leak, it is usually better to use `atomicModifyIORef'_`.-atomicModifyIORefLazy_ :: IORef a -> (a -> a) -> IO (a, a)-atomicModifyIORefLazy_ (IORef (STRef ref)) f = IO $ \s ->-  case atomicModifyMutVar_# ref f s of-    (# s', old, new #) -> (# s', (old, new) #)---- | Atomically apply a function to the contents of an--- 'IORef' and return the old and new values. The result--- of the function is forced.-atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO (a, a)-atomicModifyIORef'_ ref f = do-  (old, !new) <- atomicModifyIORefLazy_ ref f-  return (old, new)---- | Atomically replace the contents of an 'IORef', returning--- the old contents.-atomicSwapIORef :: IORef a -> a -> IO a--- Bad implementation! This will be a primop shortly.-atomicSwapIORef (IORef (STRef ref)) new = IO $ \s ->-  case atomicModifyMutVar2# ref (\_old -> Box new) s of-    (# s', old, Box _new #) -> (# s', old #)--data Box a = Box a---- | Strict version of 'Data.IORef.atomicModifyIORef'. This forces both--- the value stored in the 'IORef' and the value returned. The new value--- is installed in the 'IORef' before the returned value is forced.--- So------ @atomicModifyIORef' ref (\x -> (x+1, undefined))@------ will increment the 'IORef' and then throw an exception in the calling--- thread.------ @since 4.6.0.0-atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b--- See Note [atomicModifyIORef' definition]-atomicModifyIORef' ref f = do-  (_old, (_new, !res)) <- atomicModifyIORef2 ref $-    \old -> case f old of-       r@(!_new, _res) -> r-  pure res---- Note [atomicModifyIORef' definition]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ atomicModifyIORef' was historically defined------    atomicModifyIORef' ref f = do---        b <- atomicModifyIORef ref $ \a ->---                case f a of---                    v@(a',_) -> a' `seq` v---        b `seq` return b------ The most obvious definition, now that we have atomicModifyMutVar2#,--- would be------    atomicModifyIORef' ref f = do---      (_old, (!_new, !res)) <- atomicModifyIORef2 ref f---      pure res------ Why do we force the new value on the "inside" instead of afterwards?--- I initially thought the latter would be okay, but then I realized--- that if we write------   atomicModifyIORef' ref $ \x -> (x + 5, x - 5)------ then we'll end up building a pair of thunks to calculate x + 5--- and x - 5. That's no good! With the more complicated definition,--- we avoid this problem; the result pair is strict in the new IORef--- contents. Of course, if the function passed to atomicModifyIORef'--- doesn't inline, we'll build a closure for it. But that was already--- true for the historical definition of atomicModifyIORef' (in terms--- of atomicModifyIORef), so we shouldn't lose anything. Note that--- in keeping with the historical behavior, we *don't* propagate the--- strict demand on the result inwards. In particular,------   atomicModifyIORef' ref (\x -> (x + 1, undefined))------ will increment the IORef and throw an exception; it will not--- install an undefined value in the IORef.------ A clearer version, in my opinion (but one quite incompatible with--- the traditional one) would only force the new IORef value and not--- the result. This version would have been relatively inefficient--- to implement using atomicModifyMutVar#, but is just fine now.
− GHC/Int.hs 
@@ -1,1250 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UnboxedTuples #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Int--- Copyright   :  (c) The University of Glasgow 1997-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The sized integral datatypes, 'Int8', 'Int16', 'Int32', and 'Int64'.-----------------------------------------------------------------------------------#include "MachDeps.h"--module GHC.Int (-        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-import Data.Maybe--#if WORD_SIZE_IN_BITS < 64-import GHC.Prim-#endif--import GHC.Base-import GHC.Enum-import GHC.Num-import GHC.Real-import GHC.Read-import GHC.Arr-import GHC.Show----------------------------------------------------------------------------- type Int8----------------------------------------------------------------------------- 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# Int8#--- ^ 8-bit signed integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Int8 where-    (==) = eqInt8-    (/=) = neInt8--eqInt8, neInt8 :: Int8 -> Int8 -> Bool-eqInt8 (I8# x) (I8# y) = isTrue# ((int8ToInt# x) ==# (int8ToInt# y))-neInt8 (I8# x) (I8# y) = isTrue# ((int8ToInt# x) /=# (int8ToInt# y))-{-# INLINE [1] eqInt8 #-}-{-# INLINE [1] neInt8 #-}---- | @since 2.01-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 `gtInt8#` y)-(I8# x) `geInt8` (I8# y) = isTrue# (x `geInt8#` y)-(I8# x) `ltInt8` (I8# y) = isTrue# (x `ltInt8#` y)-(I8# x) `leInt8` (I8# y) = isTrue# (x `leInt8#` y)---- | @since 2.01-instance Show Int8 where-    showsPrec p x = showsPrec p (fromIntegral x :: Int)---- | @since 2.01-instance Num Int8 where-    (I8# x#) + (I8# y#)    = I8# (intToInt8# ((int8ToInt# x#) +# (int8ToInt# y#)))-    (I8# x#) - (I8# y#)    = I8# (intToInt8# ((int8ToInt# x#) -# (int8ToInt# y#)))-    (I8# x#) * (I8# y#)    = I8# (intToInt8# ((int8ToInt# x#) *# (int8ToInt# y#)))-    negate (I8# x#)        = I8# (intToInt8# (negateInt# (int8ToInt# x#)))-    abs x | x >= 0         = x-          | otherwise      = negate x-    signum x | x > 0       = 1-    signum 0               = 0-    signum _               = -1-    fromInteger i          = I8# (intToInt8# (integerToInt# i))---- | @since 2.01-instance Real Int8 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Enum Int8 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Int8"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Int8"-    toEnum i@(I# i#)-        | i >= fromIntegral (minBound::Int8) && i <= fromIntegral (maxBound::Int8)-                        = I8# (intToInt8# i#)-        | otherwise     = toEnumError "Int8" i (minBound::Int8, maxBound::Int8)-    fromEnum (I8# x#)   = I# (int8ToInt# x#)-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen---- | @since 2.01-instance Integral Int8 where-    quot    x@(I8# x#) y@(I8# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I8# (intToInt8# ((int8ToInt# x#) `quotInt#` (int8ToInt# y#)))-    rem     (I8# x#) y@(I8# y#)-        | y == 0                     = divZeroError-          -- The quotRem CPU instruction might fail for 'minBound-          -- `quotRem` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `rem` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I8# (intToInt8# ((int8ToInt# x#) `remInt#` (int8ToInt# y#)))-    div     x@(I8# x#) y@(I8# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I8# (intToInt8# ((int8ToInt# x#) `divInt#` (int8ToInt# y#)))-    mod       (I8# x#) y@(I8# y#)-        | y == 0                     = divZeroError-          -- The divMod CPU instruction might fail for 'minBound-          -- `divMod` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `mod` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I8# (intToInt8# ((int8ToInt# x#) `modInt#` (int8ToInt# y#)))-    quotRem x@(I8# x#) y@(I8# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case (int8ToInt# x#) `quotRemInt#` (int8ToInt# y#) of-                                       (# q, r #) ->-                                           (I8# (intToInt8# q),-                                            I8# (intToInt8# r))-    divMod  x@(I8# x#) y@(I8# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case (int8ToInt# x#) `divModInt#` (int8ToInt# y#) of-                                       (# d, m #) ->-                                           (I8# (intToInt8# d),-                                            I8# (intToInt8# m))-    toInteger (I8# x#)               = IS (int8ToInt# x#)---- | @since 2.01-instance Bounded Int8 where-    minBound = -0x80-    maxBound =  0x7F---- | @since 2.01-instance Ix Int8 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m-    inRange (m,n) i     = m <= i && i <= n---- | @since 2.01-instance Read Int8 where-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Bits Int8 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (I8# x#) .&.   (I8# y#)   = I8# (intToInt8# ((int8ToInt# x#) `andI#` (int8ToInt# y#)))-    (I8# x#) .|.   (I8# y#)   = I8# (intToInt8# ((int8ToInt# x#) `orI#`  (int8ToInt# y#)))-    (I8# x#) `xor` (I8# y#)   = I8# (intToInt8# ((int8ToInt# x#) `xorI#` (int8ToInt# y#)))-    complement (I8# x#)       = I8# (intToInt8# (notI# (int8ToInt# x#)))-    (I8# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#) = I8# (intToInt8# ((int8ToInt# x#) `iShiftL#` i#))-        | otherwise           = I8# (intToInt8# ((int8ToInt# x#) `iShiftRA#` negateInt# i#))-    (I8# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#) = I8# (intToInt8# ((int8ToInt# x#) `iShiftL#` i#))-        | otherwise           = overflowError-    (I8# x#) `unsafeShiftL` (I# i#) = I8# (intToInt8# ((int8ToInt# x#) `uncheckedIShiftL#` i#))-    (I8# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#) = I8# (intToInt8# ((int8ToInt# x#) `iShiftRA#` i#))-        | otherwise           = overflowError-    (I8# x#) `unsafeShiftR` (I# i#) = I8# (intToInt8# ((int8ToInt# x#) `uncheckedIShiftRA#` i#))-    (I8# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#)-        = I8# x#-        | otherwise-        = I8# (intToInt8# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`-                                       (x'# `uncheckedShiftRL#` (8# -# i'#)))))-        where-        !x'# = narrow8Word# (int2Word# (int8ToInt# x#))-        !i'# = word2Int# (int2Word# i# `and#` 7##)-    bitSizeMaybe i            = Just (finiteBitSize i)-    bitSize i                 = finiteBitSize i-    isSigned _                = True-    popCount (I8# x#)         = I# (word2Int# (popCnt8# (int2Word# (int8ToInt# x#))))-    bit                       = bitDefault-    testBit                   = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Int8 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 8-    countLeadingZeros  (I8# x#) = I# (word2Int# (clz8# (int2Word# (int8ToInt# x#))))-    countTrailingZeros (I8# x#) = I# (word2Int# (ctz8# (int2Word# (int8ToInt# x#))))--{-# RULES-"properFraction/Float->(Int8,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int8) n, y :: Float) }-"truncate/Float->Int8"-    truncate = (fromIntegral :: Int -> Int8) . (truncate :: Float -> Int)-"floor/Float->Int8"-    floor    = (fromIntegral :: Int -> Int8) . (floor :: Float -> Int)-"ceiling/Float->Int8"-    ceiling  = (fromIntegral :: Int -> Int8) . (ceiling :: Float -> Int)-"round/Float->Int8"-    round    = (fromIntegral :: Int -> Int8) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Int8,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int8) n, y :: Double) }-"truncate/Double->Int8"-    truncate = (fromIntegral :: Int -> Int8) . (truncate :: Double -> Int)-"floor/Double->Int8"-    floor    = (fromIntegral :: Int -> Int8) . (floor :: Double -> Int)-"ceiling/Double->Int8"-    ceiling  = (fromIntegral :: Int -> Int8) . (ceiling :: Double -> Int)-"round/Double->Int8"-    round    = (fromIntegral :: Int -> Int8) . (round  :: Double -> Int)-  #-}----------------------------------------------------------------------------- type Int16----------------------------------------------------------------------------- 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# Int16#--- ^ 16-bit signed integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Int16 where-    (==) = eqInt16-    (/=) = neInt16--eqInt16, neInt16 :: Int16 -> Int16 -> Bool-eqInt16 (I16# x) (I16# y) = isTrue# ((int16ToInt# x) ==# (int16ToInt# y))-neInt16 (I16# x) (I16# y) = isTrue# ((int16ToInt# x) /=# (int16ToInt# y))-{-# INLINE [1] eqInt16 #-}-{-# INLINE [1] neInt16 #-}---- | @since 2.01-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 `gtInt16#` y)-(I16# x) `geInt16` (I16# y) = isTrue# (x `geInt16#` y)-(I16# x) `ltInt16` (I16# y) = isTrue# (x `ltInt16#` y)-(I16# x) `leInt16` (I16# y) = isTrue# (x `leInt16#` y)---- | @since 2.01-instance Show Int16 where-    showsPrec p x = showsPrec p (fromIntegral x :: Int)---- | @since 2.01-instance Num Int16 where-    (I16# x#) + (I16# y#)  = I16# (intToInt16# ((int16ToInt# x#) +# (int16ToInt# y#)))-    (I16# x#) - (I16# y#)  = I16# (intToInt16# ((int16ToInt# x#) -# (int16ToInt# y#)))-    (I16# x#) * (I16# y#)  = I16# (intToInt16# ((int16ToInt# x#) *# (int16ToInt# y#)))-    negate (I16# x#)       = I16# (intToInt16# (negateInt# (int16ToInt# x#)))-    abs x | x >= 0         = x-          | otherwise      = negate x-    signum x | x > 0       = 1-    signum 0               = 0-    signum _               = -1-    fromInteger i          = I16# (intToInt16# (integerToInt# i))---- | @since 2.01-instance Real Int16 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Enum Int16 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Int16"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Int16"-    toEnum i@(I# i#)-        | i >= fromIntegral (minBound::Int16) && i <= fromIntegral (maxBound::Int16)-                        = I16# (intToInt16# i#)-        | otherwise     = toEnumError "Int16" i (minBound::Int16, maxBound::Int16)-    fromEnum (I16# x#)  = I# (int16ToInt# x#)-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen---- | @since 2.01-instance Integral Int16 where-    quot    x@(I16# x#) y@(I16# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I16# (intToInt16# ((int16ToInt# x#) `quotInt#` (int16ToInt# y#)))-    rem       (I16# x#) y@(I16# y#)-        | y == 0                     = divZeroError-          -- The quotRem CPU instruction might fail for 'minBound-          -- `quotRem` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `rem` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I16# (intToInt16# ((int16ToInt# x#) `remInt#` (int16ToInt# y#)))-    div     x@(I16# x#) y@(I16# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I16# (intToInt16# ((int16ToInt# x#) `divInt#` (int16ToInt# y#)))-    mod       (I16# x#) y@(I16# y#)-        | y == 0                     = divZeroError-          -- The divMod CPU instruction might fail for 'minBound-          -- `divMod` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `mod` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I16# (intToInt16# ((int16ToInt# x#) `modInt#` (int16ToInt# y#)))-    quotRem x@(I16# x#) y@(I16# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case (int16ToInt# x#) `quotRemInt#` (int16ToInt# y#) of-                                       (# q, r #) ->-                                           (I16# (intToInt16# q),-                                            I16# (intToInt16# r))-    divMod  x@(I16# x#) y@(I16# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case (int16ToInt# x#) `divModInt#` (int16ToInt# y#) of-                                       (# d, m #) ->-                                           (I16# (intToInt16# d),-                                            I16# (intToInt16# m))-    toInteger (I16# x#)              = IS (int16ToInt# x#)---- | @since 2.01-instance Bounded Int16 where-    minBound = -0x8000-    maxBound =  0x7FFF---- | @since 2.01-instance Ix Int16 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m-    inRange (m,n) i     = m <= i && i <= n---- | @since 2.01-instance Read Int16 where-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Bits Int16 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (I16# x#) .&.   (I16# y#)  = I16# (intToInt16# ((int16ToInt# x#) `andI#` (int16ToInt# y#)))-    (I16# x#) .|.   (I16# y#)  = I16# (intToInt16# ((int16ToInt# x#) `orI#`  (int16ToInt# y#)))-    (I16# x#) `xor` (I16# y#)  = I16# (intToInt16# ((int16ToInt# x#) `xorI#` (int16ToInt# y#)))-    complement (I16# x#)       = I16# (intToInt16# (notI# (int16ToInt# x#)))-    (I16# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = I16# (intToInt16# ((int16ToInt# x#) `iShiftL#` i#))-        | otherwise            = I16# (intToInt16# ((int16ToInt# x#) `iShiftRA#` negateInt# i#))-    (I16# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = I16# (intToInt16# ((int16ToInt# x#) `iShiftL#` i#))-        | otherwise            = overflowError-    (I16# x#) `unsafeShiftL` (I# i#) = I16# (intToInt16# ((int16ToInt# x#) `uncheckedIShiftL#` i#))-    (I16# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = I16# (intToInt16# ((int16ToInt# x#) `iShiftRA#` i#))-        | otherwise            = overflowError-    (I16# x#) `unsafeShiftR` (I# i#) = I16# (intToInt16# ((int16ToInt# x#) `uncheckedIShiftRA#` i#))-    (I16# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#)-        = I16# x#-        | otherwise-        = I16# (intToInt16# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`-                                         (x'# `uncheckedShiftRL#` (16# -# i'#)))))-        where-        !x'# = narrow16Word# (int2Word# (int16ToInt# x#))-        !i'# = word2Int# (int2Word# i# `and#` 15##)-    bitSizeMaybe i             = Just (finiteBitSize i)-    bitSize i                  = finiteBitSize i-    isSigned _                 = True-    popCount (I16# x#)         = I# (word2Int# (popCnt16# (int2Word# (int16ToInt# x#))))-    bit                        = bitDefault-    testBit                    = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Int16 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 16-    countLeadingZeros  (I16# x#) = I# (word2Int# (clz16# (int2Word# (int16ToInt# x#))))-    countTrailingZeros (I16# x#) = I# (word2Int# (ctz16# (int2Word# (int16ToInt# x#))))--{-# RULES-"properFraction/Float->(Int16,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int16) n, y :: Float) }-"truncate/Float->Int16"-    truncate = (fromIntegral :: Int -> Int16) . (truncate :: Float -> Int)-"floor/Float->Int16"-    floor    = (fromIntegral :: Int -> Int16) . (floor :: Float -> Int)-"ceiling/Float->Int16"-    ceiling  = (fromIntegral :: Int -> Int16) . (ceiling :: Float -> Int)-"round/Float->Int16"-    round    = (fromIntegral :: Int -> Int16) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Int16,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int16) n, y :: Double) }-"truncate/Double->Int16"-    truncate = (fromIntegral :: Int -> Int16) . (truncate :: Double -> Int)-"floor/Double->Int16"-    floor    = (fromIntegral :: Int -> Int16) . (floor :: Double -> Int)-"ceiling/Double->Int16"-    ceiling  = (fromIntegral :: Int -> Int16) . (ceiling :: Double -> Int)-"round/Double->Int16"-    round    = (fromIntegral :: Int -> Int16) . (round  :: Double -> Int)-  #-}----------------------------------------------------------------------------- type Int32---------------------------------------------------------------------------data {-# CTYPE "HsInt32" #-} Int32 = I32# Int32#--- ^ 32-bit signed integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Int32 where-    (==) = eqInt32-    (/=) = neInt32--eqInt32, neInt32 :: Int32 -> Int32 -> Bool-eqInt32 (I32# x) (I32# y) = isTrue# ((int32ToInt# x) ==# (int32ToInt# y))-neInt32 (I32# x) (I32# y) = isTrue# ((int32ToInt# x) /=# (int32ToInt# y))-{-# INLINE [1] eqInt32 #-}-{-# INLINE [1] neInt32 #-}---- | @since 2.01-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 `gtInt32#` y)-(I32# x) `geInt32` (I32# y) = isTrue# (x `geInt32#` y)-(I32# x) `ltInt32` (I32# y) = isTrue# (x `ltInt32#` y)-(I32# x) `leInt32` (I32# y) = isTrue# (x `leInt32#` y)---- | @since 2.01-instance Show Int32 where-    showsPrec p x = showsPrec p (fromIntegral x :: Int)---- | @since 2.01-instance Num Int32 where-    (I32# x#) + (I32# y#)  = I32# (intToInt32# ((int32ToInt# x#) +# (int32ToInt# y#)))-    (I32# x#) - (I32# y#)  = I32# (intToInt32# ((int32ToInt# x#) -# (int32ToInt# y#)))-    (I32# x#) * (I32# y#)  = I32# (intToInt32# ((int32ToInt# x#) *# (int32ToInt# y#)))-    negate (I32# x#)       = I32# (intToInt32# (negateInt# (int32ToInt# x#)))-    abs x | x >= 0         = x-          | otherwise      = negate x-    signum x | x > 0       = 1-    signum 0               = 0-    signum _               = -1-    fromInteger i          = I32# (intToInt32# (integerToInt# i))---- | @since 2.01-instance Enum Int32 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Int32"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Int32"-#if WORD_SIZE_IN_BITS == 32-    toEnum (I# i#)      = I32# (intToInt32# i#)-#else-    toEnum i@(I# i#)-        | i >= fromIntegral (minBound::Int32) && i <= fromIntegral (maxBound::Int32)-                        = I32# (intToInt32# i#)-        | otherwise     = toEnumError "Int32" i (minBound::Int32, maxBound::Int32)-#endif-    fromEnum (I32# x#)  = I# (int32ToInt# x#)-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen---- | @since 2.01-instance Integral Int32 where-    quot    x@(I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I32# (intToInt32# ((int32ToInt# x#) `quotInt#` (int32ToInt# y#)))-    rem       (I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-          -- The quotRem CPU instruction might fail for 'minBound-          -- `quotRem` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `rem` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I32# (intToInt32# ((int32ToInt# x#) `remInt#` (int32ToInt# y#)))-    div     x@(I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I32# (intToInt32# ((int32ToInt# x#) `divInt#` (int32ToInt# y#)))-    mod       (I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-          -- The divMod CPU instruction might fail for 'minBound-          -- `divMod` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `mod` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I32# (intToInt32# ((int32ToInt# x#) `modInt#` (int32ToInt# y#)))-    quotRem x@(I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case (int32ToInt# x#) `quotRemInt#` (int32ToInt# y#) of-                                       (# q, r #) ->-                                           (I32# (intToInt32# q),-                                            I32# (intToInt32# r))-    divMod  x@(I32# x#) y@(I32# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case (int32ToInt# x#) `divModInt#` (int32ToInt# y#) of-                                       (# d, m #) ->-                                           (I32# (intToInt32# d),-                                            I32# (intToInt32# m))-    toInteger (I32# x#)              = IS (int32ToInt# x#)---- | @since 2.01-instance Read Int32 where-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Bits Int32 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (I32# x#) .&.   (I32# y#)  = I32# (intToInt32# ((int32ToInt# x#) `andI#` (int32ToInt# y#)))-    (I32# x#) .|.   (I32# y#)  = I32# (intToInt32# ((int32ToInt# x#) `orI#`  (int32ToInt# y#)))-    (I32# x#) `xor` (I32# y#)  = I32# (intToInt32# ((int32ToInt# x#) `xorI#` (int32ToInt# y#)))-    complement (I32# x#)       = I32# (intToInt32# (notI# (int32ToInt# x#)))-    (I32# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = I32# (intToInt32# ((int32ToInt# x#) `iShiftL#` i#))-        | otherwise            = I32# (intToInt32# ((int32ToInt# x#) `iShiftRA#` negateInt# i#))-    (I32# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = I32# (intToInt32# ((int32ToInt# x#) `iShiftL#` i#))-        | otherwise            = overflowError-    (I32# x#) `unsafeShiftL` (I# i#) =-        I32# (intToInt32# ((int32ToInt# x#) `uncheckedIShiftL#` i#))-    (I32# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = I32# (intToInt32# ((int32ToInt# x#) `iShiftRA#` i#))-        | otherwise            = overflowError-    (I32# x#) `unsafeShiftR` (I# i#) = I32# (intToInt32# ((int32ToInt# x#) `uncheckedIShiftRA#` i#))-    (I32# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#)-        = I32# x#-        | otherwise-        = I32# (intToInt32# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`-                                         (x'# `uncheckedShiftRL#` (32# -# i'#)))))-        where-        !x'# = narrow32Word# (int2Word# (int32ToInt# x#))-        !i'# = word2Int# (int2Word# i# `and#` 31##)-    bitSizeMaybe i             = Just (finiteBitSize i)-    bitSize i                  = finiteBitSize i-    isSigned _                 = True-    popCount (I32# x#)         = I# (word2Int# (popCnt32# (int2Word# (int32ToInt# x#))))-    bit                        = bitDefault-    testBit                    = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Int32 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 32-    countLeadingZeros  (I32# x#) = I# (word2Int# (clz32# (int2Word# (int32ToInt# x#))))-    countTrailingZeros (I32# x#) = I# (word2Int# (ctz32# (int2Word# (int32ToInt# x#))))--{-# RULES-"properFraction/Float->(Int32,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int32) n, y :: Float) }-"truncate/Float->Int32"-    truncate = (fromIntegral :: Int -> Int32) . (truncate :: Float -> Int)-"floor/Float->Int32"-    floor    = (fromIntegral :: Int -> Int32) . (floor :: Float -> Int)-"ceiling/Float->Int32"-    ceiling  = (fromIntegral :: Int -> Int32) . (ceiling :: Float -> Int)-"round/Float->Int32"-    round    = (fromIntegral :: Int -> Int32) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Int32,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int32) n, y :: Double) }-"truncate/Double->Int32"-    truncate = (fromIntegral :: Int -> Int32) . (truncate :: Double -> Int)-"floor/Double->Int32"-    floor    = (fromIntegral :: Int -> Int32) . (floor :: Double -> Int)-"ceiling/Double->Int32"-    ceiling  = (fromIntegral :: Int -> Int32) . (ceiling :: Double -> Int)-"round/Double->Int32"-    round    = (fromIntegral :: Int -> Int32) . (round  :: Double -> Int)-  #-}---- | @since 2.01-instance Real Int32 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Bounded Int32 where-    minBound = -0x80000000-    maxBound =  0x7FFFFFFF---- | @since 2.01-instance Ix Int32 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m-    inRange (m,n) i     = m <= i && i <= n----------------------------------------------------------------------------- type Int64---------------------------------------------------------------------------#if WORD_SIZE_IN_BITS < 64--data {-# CTYPE "HsInt64" #-} Int64 = I64# Int64#--- ^ 64-bit signed integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Int64 where-    (==) = 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 #-}---- | @since 2.01-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 `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)---- | @since 2.01-instance Show Int64 where-    showsPrec p x = showsPrec p (toInteger x)---- | @since 2.01-instance Num Int64 where-    (I64# x#) + (I64# y#)  = I64# (x# `plusInt64#`  y#)-    (I64# x#) - (I64# y#)  = I64# (x# `subInt64#` y#)-    (I64# x#) * (I64# y#)  = I64# (x# `timesInt64#` y#)-    negate (I64# x#)       = I64# (negateInt64# x#)-    abs x | x >= 0         = x-          | otherwise      = negate x-    signum x | x > 0       = 1-    signum 0               = 0-    signum _               = -1-    fromInteger i          = I64# (integerToInt64# i)---- | @since 2.01-instance Enum Int64 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Int64"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Int64"-    toEnum (I# i#)      = I64# (intToInt64# i#)-    fromEnum x@(I64# x#)-        | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)-                        = I# (int64ToInt# x#)-        | otherwise     = fromEnumError "Int64" x-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = integralEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = integralEnumFromThen-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromTo #-}-    enumFromTo          = integralEnumFromTo-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThenTo #-}-    enumFromThenTo      = integralEnumFromThenTo---- | @since 2.01-instance Integral Int64 where-    quot    x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I64# (x# `quotInt64#` y#)-    rem       (I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- The quotRem CPU instruction might fail for 'minBound-          -- `quotRem` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `rem` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I64# (x# `remInt64#` y#)-    div     x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I64# (x# `divInt64#` y#)-    mod       (I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- The divMod CPU instruction might fail for 'minBound-          -- `divMod` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `mod` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I64# (x# `modInt64#` y#)-    quotRem x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I64# (x# `quotInt64#` y#),-                                        I64# (x# `remInt64#` y#))-    divMod  x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = (I64# (x# `divInt64#` y#),-                                        I64# (x# `modInt64#` y#))-    toInteger (I64# x)               = integerFromInt64# x---divInt64#, modInt64# :: Int64# -> Int64# -> Int64#---- Define div in terms of quot, being careful to avoid overflow (#7233)-x# `divInt64#` y#-    | isTrue# (x# `gtInt64#` zero) && isTrue# (y# `ltInt64#` zero)-        = ((x# `subInt64#` one) `quotInt64#` y#) `subInt64#` one-    | isTrue# (x# `ltInt64#` zero) && isTrue# (y# `gtInt64#` zero)-        = ((x# `plusInt64#` one)  `quotInt64#` y#) `subInt64#` one-    | otherwise-        = x# `quotInt64#` y#-    where-    !zero = intToInt64# 0#-    !one  = intToInt64# 1#--x# `modInt64#` y#-    | isTrue# (x# `gtInt64#` zero) && isTrue# (y# `ltInt64#` zero) ||-      isTrue# (x# `ltInt64#` zero) && isTrue# (y# `gtInt64#` zero)-        = if isTrue# (r# `neInt64#` zero) then r# `plusInt64#` y# else zero-    | otherwise = r#-    where-    !zero = intToInt64# 0#-    !r# = x# `remInt64#` y#---- | @since 2.01-instance Read Int64 where-    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Bits Int64 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (I64# x#) .&.   (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#))-    (I64# x#) .|.   (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `or64#`  int64ToWord64# y#))-    (I64# x#) `xor` (I64# y#)  = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#))-    complement (I64# x#)       = I64# (word64ToInt64# (not64# (int64ToWord64# x#)))-    (I64# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = I64# (x# `iShiftL64#` i#)-        | otherwise            = I64# (x# `iShiftRA64#` negateInt# i#)-    (I64# x#) `shiftL` (I# i#)-        | isTrue# (i# >=# 0#)  = I64# (x# `iShiftL64#` i#)-        | otherwise            = overflowError-    (I64# x#) `unsafeShiftL` (I# i#) = I64# (x# `uncheckedIShiftL64#` i#)-    (I64# x#) `shiftR` (I# i#)-        | isTrue# (i# >=# 0#)  = I64# (x# `iShiftRA64#` i#)-        | otherwise            = overflowError-    (I64# x#) `unsafeShiftR` (I# i#) = I64# (x# `uncheckedIShiftRA64#` i#)-    (I64# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#)-        = I64# x#-        | otherwise-        = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#`-                                (x'# `uncheckedShiftRL64#` (64# -# i'#))))-        where-        !x'# = int64ToWord64# x#-        !i'# = word2Int# (int2Word# i# `and#` 63##)-    bitSizeMaybe i             = Just (finiteBitSize i)-    bitSize i                  = finiteBitSize i-    isSigned _                 = True-    popCount (I64# x#)         =-        I# (word2Int# (popCnt64# (int64ToWord64# x#)))-    bit                        = bitDefault-    testBit                    = testBitDefault---- give the 64-bit shift operations the same treatment as the 32-bit--- ones (see GHC.Base), namely we wrap them in tests to catch the--- cases when we're shifting more than 64 bits to avoid unspecified--- behaviour in the C shift operations.--iShiftL64#, iShiftRA64# :: Int64# -> Int# -> Int64#--a `iShiftL64#` b  | isTrue# (b >=# 64#) = intToInt64# 0#-                  | otherwise           = a `uncheckedIShiftL64#` b--a `iShiftRA64#` b | isTrue# (b >=# 64#) = if isTrue# (a `ltInt64#` (intToInt64# 0#))-                                          then intToInt64# (-1#)-                                          else intToInt64# 0#-                  | otherwise = a `uncheckedIShiftRA64#` b---- No RULES for RealFrac methods if Int is smaller than Int64, we can't--- go through Int and whether going through Integer is faster is uncertain.-#else---- Int64 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 "HsInt64" #-} Int64 = I64# Int#--- ^ 64-bit signed integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-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 #-}---- | @since 2.01-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)---- | @since 2.01-instance Show Int64 where-    showsPrec p x = showsPrec p (fromIntegral x :: Int)---- | @since 2.01-instance Num Int64 where-    (I64# x#) + (I64# y#)  = I64# (x# +# y#)-    (I64# x#) - (I64# y#)  = I64# (x# -# y#)-    (I64# x#) * (I64# y#)  = I64# (x# *# y#)-    negate (I64# x#)       = I64# (negateInt# x#)-    abs x | x >= 0         = x-          | otherwise      = negate x-    signum x | x > 0       = 1-    signum 0               = 0-    signum _               = -1-    fromInteger i          = I64# (integerToInt# i)---- | @since 2.01-instance Enum Int64 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Int64"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Int64"-    toEnum (I# i#)      = I64# i#-    fromEnum (I64# x#)  = I# x#-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen---- | @since 2.01-instance Integral Int64 where-    quot    x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I64# (x# `quotInt#` y#)-    rem       (I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- The quotRem CPU instruction might fail for 'minBound-          -- `quotRem` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `rem` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I64# (x# `remInt#` y#)-    div     x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]-        | otherwise                  = I64# (x# `divInt#` y#)-    mod       (I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- The divMod CPU instruction might fail for 'minBound-          -- `divMod` -1' if it is an instruction for exactly this-          -- width of signed integer. But, 'minBound `mod` -1' is-          -- well-defined (0). We therefore special-case it.-        | y == (-1)                  = 0-        | otherwise                  = I64# (x# `modInt#` y#)-    quotRem x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case x# `quotRemInt#` y# of-                                       (# q, r #) ->-                                           (I64# q, I64# r)-    divMod  x@(I64# x#) y@(I64# y#)-        | y == 0                     = divZeroError-          -- Note [Order of tests]-        | y == (-1) && x == minBound = (overflowError, 0)-        | otherwise                  = case x# `divModInt#` y# of-                                       (# d, m #) ->-                                           (I64# d, I64# m)-    toInteger (I64# x#)              = IS x#---- | @since 2.01-instance Read Int64 where-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Bits Int64 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (I64# x#) .&.   (I64# y#)  = I64# (x# `andI#` y#)-    (I64# x#) .|.   (I64# y#)  = I64# (x# `orI#`  y#)-    (I64# x#) `xor` (I64# y#)  = I64# (x# `xorI#` y#)-    complement (I64# x#)       = I64# (notI# x#)-    (I64# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = I64# (x# `iShiftL#` i#)-        | otherwise            = I64# (x# `iShiftRA#` negateInt# i#)-    (I64# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = I64# (x# `iShiftL#` i#)-        | otherwise            = overflowError-    (I64# x#) `unsafeShiftL` (I# i#) = I64# (x# `uncheckedIShiftL#` i#)-    (I64# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = I64# (x# `iShiftRA#` i#)-        | otherwise            = overflowError-    (I64# x#) `unsafeShiftR` (I# i#) = I64# (x# `uncheckedIShiftRA#` i#)-    (I64# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#)-        = I64# x#-        | otherwise-        = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`-                           (x'# `uncheckedShiftRL#` (64# -# i'#))))-        where-        !x'# = int2Word# x#-        !i'# = word2Int# (int2Word# i# `and#` 63##)-    bitSizeMaybe i             = Just (finiteBitSize i)-    bitSize i                  = finiteBitSize i-    isSigned _                 = True-    popCount (I64# x#)         = I# (word2Int# (popCnt64# (int2Word# x#)))-    bit                        = bitDefault-    testBit                    = testBitDefault--{-# RULES-"properFraction/Float->(Int64,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int64) n, y :: Float) }-"truncate/Float->Int64"-    truncate = (fromIntegral :: Int -> Int64) . (truncate :: Float -> Int)-"floor/Float->Int64"-    floor    = (fromIntegral :: Int -> Int64) . (floor :: Float -> Int)-"ceiling/Float->Int64"-    ceiling  = (fromIntegral :: Int -> Int64) . (ceiling :: Float -> Int)-"round/Float->Int64"-    round    = (fromIntegral :: Int -> Int64) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Int64,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Int64) n, y :: Double) }-"truncate/Double->Int64"-    truncate = (fromIntegral :: Int -> Int64) . (truncate :: Double -> Int)-"floor/Double->Int64"-    floor    = (fromIntegral :: Int -> Int64) . (floor :: Double -> Int)-"ceiling/Double->Int64"-    ceiling  = (fromIntegral :: Int -> Int64) . (ceiling :: Double -> Int)-"round/Double->Int64"-    round    = (fromIntegral :: Int -> Int64) . (round  :: Double -> Int)-  #-}--uncheckedIShiftL64# :: Int# -> Int# -> Int#-uncheckedIShiftL64#  = uncheckedIShiftL#--uncheckedIShiftRA64# :: Int# -> Int# -> Int#-uncheckedIShiftRA64# = uncheckedIShiftRA#-#endif---- | @since 4.6.0.0-instance FiniteBits Int64 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 64-#if WORD_SIZE_IN_BITS < 64-    countLeadingZeros  (I64# x#) = I# (word2Int# (clz64# (int64ToWord64# x#)))-    countTrailingZeros (I64# x#) = I# (word2Int# (ctz64# (int64ToWord64# x#)))-#else-    countLeadingZeros  (I64# x#) = I# (word2Int# (clz64# (int2Word# x#)))-    countTrailingZeros (I64# x#) = I# (word2Int# (ctz64# (int2Word# x#)))-#endif---- | @since 2.01-instance Real Int64 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Bounded Int64 where-    minBound = -0x8000000000000000-    maxBound =  0x7FFFFFFFFFFFFFFF---- | @since 2.01-instance Ix Int64 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m-    inRange (m,n) i     = m <= i && i <= n-----------------------------------------------------------------------------------{- Note [Order of tests]-~~~~~~~~~~~~~~~~~~~~~~~~~-(See #3065, #5161.) Suppose we had a definition like:--    quot x y-     | y == 0                     = divZeroError-     | x == minBound && y == (-1) = overflowError-     | otherwise                  = x `primQuot` y--Note in particular that the-    x == minBound-test comes before the-    y == (-1)-test.--this expands to something like:--    case y of-    0 -> divZeroError-    _ -> case x of-         -9223372036854775808 ->-             case y of-             -1 -> overflowError-             _ -> x `primQuot` y-         _ -> x `primQuot` y--Now if we have the call (x `quot` 2), and quot gets inlined, then we get:--    case 2 of-    0 -> divZeroError-    _ -> case x of-         -9223372036854775808 ->-             case 2 of-             -1 -> overflowError-             _ -> x `primQuot` 2-         _ -> x `primQuot` 2--which simplifies to:--    case x of-    -9223372036854775808 -> x `primQuot` 2-    _                    -> x `primQuot` 2--Now we have a case with two identical branches, which would be-eliminated (assuming it doesn't affect strictness, which it doesn't in-this case), leaving the desired:--    x `primQuot` 2--except in the minBound branch we know what x is, and GHC cleverly does-the division at compile time, giving:--    case x of-    -9223372036854775808 -> -4611686018427387904-    _                    -> x `primQuot` 2--So instead we use a definition like:--    quot x y-     | y == 0                     = divZeroError-     | y == (-1) && x == minBound = overflowError-     | otherwise                  = x `primQuot` y--which gives us:--    case y of-    0 -> divZeroError-    -1 ->-        case x of-        -9223372036854775808 -> overflowError-        _ -> x `primQuot` y-    _ -> x `primQuot` y--for which our call (x `quot` 2) expands to:--    case 2 of-    0 -> divZeroError-    -1 ->-        case x of-        -9223372036854775808 -> overflowError-        _ -> x `primQuot` 2-    _ -> x `primQuot` 2--which simplifies to:--    x `primQuot` 2--as required.----But we now have the same problem with a constant numerator: the call-(2 `quot` y) expands to--    case y of-    0 -> divZeroError-    -1 ->-        case 2 of-        -9223372036854775808 -> overflowError-        _ -> 2 `primQuot` y-    _ -> 2 `primQuot` y--which simplifies to:--    case y of-    0 -> divZeroError-    -1 -> 2 `primQuot` y-    _ -> 2 `primQuot` y--which simplifies to:--    case y of-    0 -> divZeroError-    -1 -> -2-    _ -> 2 `primQuot` y---However, constant denominators are more common than constant numerators,-so the-    y == (-1) && x == minBound-order gives us better code in the common case.--}
− GHC/Integer.hs 
@@ -1,212 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE NoImplicitPrelude #-}--{-# OPTIONS_HADDOCK not-home #-}--#include "MachDeps.h"---- | Compatibility module for pre ghc-bignum code.-module GHC.Integer (-    Integer,--    -- * Construct 'Integer's-    smallInteger, wordToInteger,-#if WORD_SIZE_IN_BITS < 64-    word64ToInteger, int64ToInteger,-#endif-    -- * Conversion to other integral types-    integerToWord, integerToInt,-#if WORD_SIZE_IN_BITS < 64-    integerToWord64, integerToInt64,-#endif--    -- * Helpers for 'RealFloat' type-class operations-    encodeFloatInteger, encodeDoubleInteger, decodeDoubleInteger,--    -- * Arithmetic operations-    plusInteger, minusInteger, timesInteger, negateInteger,-    absInteger, signumInteger,--    divModInteger, divInteger, modInteger,-    quotRemInteger, quotInteger, remInteger,--    -- * Comparison predicates-    eqInteger,  neqInteger,  leInteger,  gtInteger,  ltInteger,  geInteger,-    compareInteger,--    -- ** 'Int#'-boolean valued versions of comparison predicates-    ---    -- | These operations return @0#@ and @1#@ instead of 'False' and-    -- 'True' respectively.  See-    -- <https://gitlab.haskell.org/ghc/ghc/wikis/prim-bool PrimBool wiki-page>-    -- for more details-    eqInteger#, neqInteger#, leInteger#, gtInteger#, ltInteger#, geInteger#,---    -- * Bit-operations-    andInteger, orInteger, xorInteger,--    complementInteger,-    shiftLInteger, shiftRInteger, testBitInteger,--    popCountInteger, bitInteger,--    -- * Hashing-    hashInteger,-    ) where--import GHC.Num.Integer (Integer)-import qualified GHC.Num.Integer as I-import GHC.Prim-import GHC.Types--smallInteger :: Int# -> Integer-smallInteger = I.integerFromInt#--integerToInt :: Integer -> Int#-integerToInt = I.integerToInt#--wordToInteger :: Word# -> Integer-wordToInteger = I.integerFromWord#--integerToWord :: Integer -> Word#-integerToWord = I.integerToWord#--#if WORD_SIZE_IN_BITS < 64--word64ToInteger :: Word64# -> Integer-word64ToInteger = I.integerFromWord64#--integerToWord64 :: Integer -> Word64#-integerToWord64 = I.integerToWord64#--int64ToInteger :: Int64# -> Integer-int64ToInteger = I.integerFromInt64#--integerToInt64 :: Integer -> Int64#-integerToInt64 = I.integerToInt64#--#endif---encodeFloatInteger :: Integer -> Int# -> Float#-encodeFloatInteger = I.integerEncodeFloat#--encodeDoubleInteger :: Integer -> Int# -> Double#-encodeDoubleInteger = I.integerEncodeDouble#--decodeDoubleInteger :: Double# -> (# Integer, Int# #)-decodeDoubleInteger = I.integerDecodeDouble#---plusInteger :: Integer -> Integer -> Integer-plusInteger = I.integerAdd--minusInteger :: Integer -> Integer -> Integer-minusInteger = I.integerSub--timesInteger :: Integer -> Integer -> Integer-timesInteger = I.integerMul--negateInteger :: Integer -> Integer-negateInteger = I.integerNegate--absInteger :: Integer -> Integer-absInteger = I.integerAbs--signumInteger :: Integer -> Integer-signumInteger = I.integerSignum--divModInteger :: Integer -> Integer -> (# Integer, Integer #)-divModInteger = I.integerDivMod#--divInteger :: Integer -> Integer -> Integer-divInteger = I.integerDiv--modInteger :: Integer -> Integer -> Integer-modInteger = I.integerMod--quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)-quotRemInteger = I.integerQuotRem#--quotInteger :: Integer -> Integer -> Integer-quotInteger = I.integerQuot--remInteger :: Integer -> Integer -> Integer-remInteger = I.integerRem---eqInteger :: Integer -> Integer -> Bool-eqInteger = I.integerEq--neqInteger :: Integer -> Integer -> Bool-neqInteger = I.integerNe--leInteger :: Integer -> Integer -> Bool-leInteger = I.integerLe--gtInteger :: Integer -> Integer -> Bool-gtInteger = I.integerGt--ltInteger :: Integer -> Integer -> Bool-ltInteger = I.integerLt--geInteger :: Integer -> Integer -> Bool-geInteger = I.integerGe--compareInteger :: Integer -> Integer -> Ordering-compareInteger = I.integerCompare----eqInteger# :: Integer -> Integer -> Int#-eqInteger# = I.integerEq#--neqInteger# :: Integer -> Integer -> Int#-neqInteger# = I.integerNe#--leInteger# :: Integer -> Integer -> Int#-leInteger# = I.integerLe#--gtInteger# :: Integer -> Integer -> Int#-gtInteger# = I.integerGt#--ltInteger# :: Integer -> Integer -> Int#-ltInteger# = I.integerLt#--geInteger# :: Integer -> Integer -> Int#-geInteger# = I.integerGe#---andInteger :: Integer -> Integer -> Integer-andInteger = I.integerAnd--orInteger :: Integer -> Integer -> Integer-orInteger = I.integerOr--xorInteger :: Integer -> Integer -> Integer-xorInteger = I.integerXor--complementInteger :: Integer -> Integer-complementInteger = I.integerComplement--shiftLInteger :: Integer -> Int# -> Integer-shiftLInteger n i = I.integerShiftL# n (int2Word# i)--shiftRInteger :: Integer -> Int# -> Integer-shiftRInteger n i = I.integerShiftR# n (int2Word# i)--testBitInteger :: Integer -> Int# -> Bool-testBitInteger n i = isTrue# (I.integerTestBit# n (int2Word# i))--hashInteger :: Integer -> Int#-hashInteger = I.integerToInt#--bitInteger :: Int# -> Integer-bitInteger i = I.integerBit# (int2Word# i)--popCountInteger :: Integer -> Int#-popCountInteger = I.integerPopCount#-
− GHC/Integer/Logarithms.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MagicHash #-}---- | Compatibility module for pre ghc-bignum code.-module GHC.Integer.Logarithms-   ( wordLog2#-   , integerLog2#-   , integerLogBase#-   )-where--import qualified GHC.Num.Primitives as N-import qualified GHC.Num.Integer    as N-import GHC.Num.Integer (Integer)-import GHC.Prim--wordLog2# :: Word# -> Int#-wordLog2# i = word2Int# (N.wordLog2# i)--integerLog2# :: Integer -> Int#-integerLog2# i = word2Int# (N.integerLog2# i)--integerLogBase# :: Integer -> Integer -> Int#-integerLogBase# x y = word2Int# (N.integerLogBase# x y)
− GHC/Ix.hs 
@@ -1,795 +0,0 @@-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Ix--- Copyright   :  (c) The University of Glasgow, 1994-2000--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ GHC\'s Ix typeclass implementation.-----------------------------------------------------------------------------------module GHC.Ix (-        Ix(..), indexError-    ) where--import GHC.Enum-import GHC.Num-import GHC.Base-import GHC.Real( fromIntegral )-import GHC.Show-import GHC.Tuple (Solo (..))---- | The 'Ix' class is used to map a contiguous subrange of values in--- a type onto integers.  It is used primarily for array indexing--- (see the array package).------ The first argument @(l,u)@ of each of these operations is a pair--- specifying the lower and upper bounds of a contiguous subrange of values.------ An implementation is entitled to assume the following laws about these--- operations:------ * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@ @ @------ * @'range' (l,u) '!!' 'index' (l,u) i == i@, when @'inRange' (l,u) i@------ * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@ @ @------ * @'rangeSize' (l,u) == 'length' ('range' (l,u))@ @ @----class (Ord a) => Ix a where-    {-# MINIMAL range, (index | unsafeIndex), inRange #-}--    -- | The list of values in the subrange defined by a bounding pair.-    range               :: (a,a) -> [a]-    -- | The position of a subscript in the subrange.-    index               :: (a,a) -> a -> Int-    -- | Like 'index', but without checking that the value is in range.-    unsafeIndex         :: (a,a) -> a -> Int-    -- | Returns 'True' the given subscript lies in the range defined-    -- the bounding pair.-    inRange             :: (a,a) -> a -> Bool-    -- | The size of the subrange defined by a bounding pair.-    rangeSize           :: (a,a) -> Int-    -- | like 'rangeSize', but without checking that the upper bound is-    -- in range.-    unsafeRangeSize     :: (a,a) -> Int--        -- Must specify one of index, unsafeIndex--        -- 'index' is typically over-ridden in instances, with essentially-        -- the same code, but using indexError instead of hopelessIndexError-        -- Reason: we have 'Show' at the instances-    {-# INLINE index #-}  -- See Note [Inlining index]-    index b i | inRange b i = unsafeIndex b i-              | otherwise   = hopelessIndexError--    unsafeIndex b i = index b i--    rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1-                       | otherwise   = 0        -- This case is only here to-                                                -- check for an empty range-        -- NB: replacing (inRange b h) by (l <= h) fails for-        --     tuples.  E.g.  (1,2) <= (2,1) but the range is empty--    unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1--{--Note that the following is NOT right-        rangeSize (l,h) | l <= h    = index b h + 1-                        | otherwise = 0--Because it might be the case that l<h, but the range-is nevertheless empty.  Consider-        ((1,2),(2,1))-Here l<h, but the second index ranges from 2..1 and-hence is empty---Note [Inlining index]-~~~~~~~~~~~~~~~~~~~~~-We inline the 'index' operation,-- * Partly because it generates much faster code-   (although bigger); see #1216-- * Partly because it exposes the bounds checks to the simplifier which-   might help a big.--If you make a per-instance index method, you may consider inlining it.--Note [Double bounds-checking of index values]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When you index an array, a!x, there are two possible bounds checks we might make:--  (A) Check that (inRange (bounds a) x) holds.--      (A) is checked in the method for 'index'--  (B) Check that (index (bounds a) x) lies in the range 0..n,-      where n is the size of the underlying array--      (B) is checked in the top-level function (!), in safeIndex.--Of course it *should* be the case that (A) holds iff (B) holds, but that-is a property of the particular instances of index, bounds, and inRange,-so GHC cannot guarantee it.-- * If you do (A) and not (B), then you might get a seg-fault,-   by indexing at some bizarre location.  #1610-- * If you do (B) but not (A), you may get no complaint when you index-   an array out of its semantic bounds.  #2120--At various times we have had (A) and not (B), or (B) and not (A); both-led to complaints.  So now we implement *both* checks (#2669).--For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this.--Note [Out-of-bounds error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The default method for 'index' generates hoplelessIndexError, because-Ix doesn't have Show as a superclass.  For particular base types we-can do better, so we override the default method for index.--}---- Abstract these errors from the relevant index functions so that--- the guts of the function will be small enough to inline.--{-# NOINLINE indexError #-}-indexError :: Show a => (a,a) -> a -> String -> b-indexError rng i tp-  = 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 = errorWithoutStackTrace "Error in array index"--------------------------------------------------------------------------- | @since 2.01-instance  Ix Char  where-    {-# INLINE range #-}-    range (m,n) = [m..n]--    {-# INLINE unsafeIndex #-}-    unsafeIndex (m,_n) i = fromEnum i - fromEnum m--    {-# INLINE index #-}  -- See Note [Out-of-bounds error messages]-                          -- and Note [Inlining index]-    index b i | inRange b i =  unsafeIndex b i-              | otherwise   =  indexError b i "Char"--    inRange (m,n) i     =  m <= i && i <= n--------------------------------------------------------------------------- | @since 2.01-instance  Ix Int  where-    {-# INLINE range #-}-        -- The INLINE stops the build in the RHS from getting inlined,-        -- so that callers can fuse with the result of range-    range (m,n) = [m..n]--    {-# INLINE unsafeIndex #-}-    unsafeIndex (m,_n) i = i - m--    {-# INLINE index #-}  -- See Note [Out-of-bounds error messages]-                          -- and Note [Inlining index]-    index b i | inRange b i =  unsafeIndex b i-              | otherwise   =  indexError b i "Int"--    {-# INLINE inRange #-}-    inRange (I# m,I# n) (I# i) =  isTrue# (m <=# i) && isTrue# (i <=# n)---- | @since 4.6.0.0-instance Ix Word where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral (i - m)-    inRange (m,n) i     = m <= i && i <= n--------------------------------------------------------------------------- | @since 2.01-instance  Ix Integer  where-    {-# INLINE range #-}-    range (m,n) = [m..n]--    {-# INLINE unsafeIndex #-}-    unsafeIndex (m,_n) i   = fromInteger (i - m)--    {-# INLINE index #-}  -- See Note [Out-of-bounds error messages]-                          -- and Note [Inlining index]-    index b i | inRange b i =  unsafeIndex b i-              | otherwise   =  indexError b i "Integer"--    inRange (m,n) i     =  m <= i && i <= n--------------------------------------------------------------------------- | @since 4.8.0.0-instance Ix Natural where-    range (m,n) = [m..n]-    inRange (m,n) i = m <= i && i <= n-    unsafeIndex (m,_) i = fromIntegral (i-m)-    index b i | inRange b i = unsafeIndex b i-              | otherwise   = indexError b i "Natural"--------------------------------------------------------------------------- | @since 2.01-instance Ix Bool where -- as derived-    {-# INLINE range #-}-    range (m,n) = [m..n]--    {-# INLINE unsafeIndex #-}-    unsafeIndex (l,_) i = fromEnum i - fromEnum l--    {-# INLINE index #-}  -- See Note [Out-of-bounds error messages]-                          -- and Note [Inlining index]-    index b i | inRange b i =  unsafeIndex b i-              | otherwise   =  indexError b i "Bool"--    inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u--------------------------------------------------------------------------- | @since 2.01-instance Ix Ordering where -- as derived-    {-# INLINE range #-}-    range (m,n) = [m..n]--    {-# INLINE unsafeIndex #-}-    unsafeIndex (l,_) i = fromEnum i - fromEnum l--    {-# INLINE index #-}  -- See Note [Out-of-bounds error messages]-                          -- and Note [Inlining index]-    index b i | inRange b i =  unsafeIndex b i-              | otherwise   =  indexError b i "Ordering"--    inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u--------------------------------------------------------------------------- | @since 2.01-instance Ix () where-    {-# INLINE range #-}-    range   ((), ())    = [()]-    {-# INLINE unsafeIndex #-}-    unsafeIndex   ((), ()) () = 0-    {-# INLINE inRange #-}-    inRange ((), ()) () = True--    {-# INLINE index #-}  -- See Note [Inlining index]-    index b i = unsafeIndex b i--instance Ix a => Ix (Solo a) where -- as derived-    {-# SPECIALISE instance Ix (Solo Int) #-}--    {-# INLINE range #-}-    range (Solo l, Solo u) =-      [ Solo i | i <- range (l,u) ]--    {-# INLINE unsafeIndex #-}-    unsafeIndex (Solo l, Solo u) (Solo i) =-      unsafeIndex (l,u) i--    {-# INLINE inRange #-}-    inRange (Solo l, Solo u) (Solo i) =-      inRange (l, u) i--    -- Default method for index--------------------------------------------------------------------------- | @since 2.01-instance (Ix a, Ix b) => Ix (a, b) where -- as derived-    {-# SPECIALISE instance Ix (Int,Int) #-}--    {-# INLINE range #-}-    range ((l1,l2),(u1,u2)) =-      [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ]--    {-# INLINE unsafeIndex #-}-    unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) =-      unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2--    {-# INLINE inRange #-}-    inRange ((l1,l2),(u1,u2)) (i1,i2) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2--    -- Default method for index--------------------------------------------------------------------------- | @since 2.01-instance  (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3)  where-    {-# SPECIALISE instance Ix (Int,Int,Int) #-}--    range ((l1,l2,l3),(u1,u2,u3)) =-        [(i1,i2,i3) | i1 <- range (l1,u1),-                      i2 <- range (l2,u2),-                      i3 <- range (l3,u3)]--    unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))--    inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3--    -- Default method for index--------------------------------------------------------------------------- | @since 2.01-instance  (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4)  where-    range ((l1,l2,l3,l4),(u1,u2,u3,u4)) =-      [(i1,i2,i3,i4) | i1 <- range (l1,u1),-                       i2 <- range (l2,u2),-                       i3 <- range (l3,u3),-                       i4 <- range (l4,u4)]--    unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1)))--    inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4--    -- Default method for index--------------------------------------------------------------------------- | @since 2.01-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5)  where-    range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) =-      [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1),-                          i2 <- range (l2,u2),-                          i3 <- range (l3,u3),-                          i4 <- range (l4,u4),-                          i5 <- range (l5,u5)]--    unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))))--    inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6) =>-      Ix (a1,a2,a3,a4,a5,a6)  where-    range ((l1,l2,l3,l4,l5,l6),(u1,u2,u3,u4,u5,u6)) =-      [(i1,i2,i3,i4,i5,i6) | i1 <- range (l1,u1),-                             i2 <- range (l2,u2),-                             i3 <- range (l3,u3),-                             i4 <- range (l4,u4),-                             i5 <- range (l5,u5),-                             i6 <- range (l6,u6)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6),(u1,u2,u3,u4,u5,u6)) (i1,i2,i3,i4,i5,i6) =-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1)))))--    inRange ((l1,l2,l3,l4,l5,l6),(u1,u2,u3,u4,u5,u6)) (i1,i2,i3,i4,i5,i6) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7) =>-      Ix (a1,a2,a3,a4,a5,a6,a7)  where-    range ((l1,l2,l3,l4,l5,l6,l7),(u1,u2,u3,u4,u5,u6,u7)) =-      [(i1,i2,i3,i4,i5,i6,i7) | i1 <- range (l1,u1),-                                i2 <- range (l2,u2),-                                i3 <- range (l3,u3),-                                i4 <- range (l4,u4),-                                i5 <- range (l5,u5),-                                i6 <- range (l6,u6),-                                i7 <- range (l7,u7)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7),(u1,u2,u3,u4,u5,u6,u7))-        (i1,i2,i3,i4,i5,i6,i7) =-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7),(u1,u2,u3,u4,u5,u6,u7))-        (i1,i2,i3,i4,i5,i6,i7) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8),(u1,u2,u3,u4,u5,u6,u7,u8)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8) | i1 <- range (l1,u1),-                                   i2 <- range (l2,u2),-                                   i3 <- range (l3,u3),-                                   i4 <- range (l4,u4),-                                   i5 <- range (l5,u5),-                                   i6 <- range (l6,u6),-                                   i7 <- range (l7,u7),-                                   i8 <- range (l8,u8)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8),(u1,u2,u3,u4,u5,u6,u7,u8))-        (i1,i2,i3,i4,i5,i6,i7,i8) =-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1)))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8),(u1,u2,u3,u4,u5,u6,u7,u8))-        (i1,i2,i3,i4,i5,i6,i7,i8) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9),(u1,u2,u3,u4,u5,u6,u7,u8,u9)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9) | i1 <- range (l1,u1),-                                      i2 <- range (l2,u2),-                                      i3 <- range (l3,u3),-                                      i4 <- range (l4,u4),-                                      i5 <- range (l5,u5),-                                      i6 <- range (l6,u6),-                                      i7 <- range (l7,u7),-                                      i8 <- range (l8,u8),-                                      i9 <- range (l9,u9)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9),(u1,u2,u3,u4,u5,u6,u7,u8,u9))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9) =-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9),(u1,u2,u3,u4,u5,u6,u7,u8,u9))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9,-           Ix aA) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9,aA)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA),(u1,u2,u3,u4,u5,u6,u7,u8,u9,uA)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9,iA) | i1 <- range (l1,u1),-                                         i2 <- range (l2,u2),-                                         i3 <- range (l3,u3),-                                         i4 <- range (l4,u4),-                                         i5 <- range (l5,u5),-                                         i6 <- range (l6,u6),-                                         i7 <- range (l7,u7),-                                         i8 <- range (l8,u8),-                                         i9 <- range (l9,u9),-                                         iA <- range (lA,uA)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA),-                 (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA) =-      unsafeIndex (lA,uA) iA + unsafeRangeSize (lA,uA) * (-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1)))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA),(u1,u2,u3,u4,u5,u6,u7,u8,u9,uA))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9 && inRange (lA,uA) iA--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9,-           Ix aA, Ix aB) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB),-           (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB) | i1 <- range (l1,u1),-                                            i2 <- range (l2,u2),-                                            i3 <- range (l3,u3),-                                            i4 <- range (l4,u4),-                                            i5 <- range (l5,u5),-                                            i6 <- range (l6,u6),-                                            i7 <- range (l7,u7),-                                            i8 <- range (l8,u8),-                                            i9 <- range (l9,u9),-                                            iA <- range (lA,uA),-                                            iB <- range (lB,uB)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB),-                 (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB) =-      unsafeIndex (lB,uB) iB + unsafeRangeSize (lB,uB) * (-      unsafeIndex (lA,uA) iA + unsafeRangeSize (lA,uA) * (-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB),-             (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9 && inRange (lA,uA) iA &&-      inRange (lB,uB) iB--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9,-           Ix aA, Ix aB, Ix aC) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB,aC)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC),-           (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC) | i1 <- range (l1,u1),-                                               i2 <- range (l2,u2),-                                               i3 <- range (l3,u3),-                                               i4 <- range (l4,u4),-                                               i5 <- range (l5,u5),-                                               i6 <- range (l6,u6),-                                               i7 <- range (l7,u7),-                                               i8 <- range (l8,u8),-                                               i9 <- range (l9,u9),-                                               iA <- range (lA,uA),-                                               iB <- range (lB,uB),-                                               iC <- range (lC,uC)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC),-                 (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC) =-      unsafeIndex (lC,uC) iC + unsafeRangeSize (lC,uC) * (-      unsafeIndex (lB,uB) iB + unsafeRangeSize (lB,uB) * (-      unsafeIndex (lA,uA) iA + unsafeRangeSize (lA,uA) * (-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1)))))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC),-             (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9 && inRange (lA,uA) iA &&-      inRange (lB,uB) iB && inRange (lC,uC) iC--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9,-           Ix aA, Ix aB, Ix aC, Ix aD) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB,aC,aD)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD),-           (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD) | i1 <- range (l1,u1),-                                                  i2 <- range (l2,u2),-                                                  i3 <- range (l3,u3),-                                                  i4 <- range (l4,u4),-                                                  i5 <- range (l5,u5),-                                                  i6 <- range (l6,u6),-                                                  i7 <- range (l7,u7),-                                                  i8 <- range (l8,u8),-                                                  i9 <- range (l9,u9),-                                                  iA <- range (lA,uA),-                                                  iB <- range (lB,uB),-                                                  iC <- range (lC,uC),-                                                  iD <- range (lD,uD)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD),-                 (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD) =-      unsafeIndex (lD,uD) iD + unsafeRangeSize (lD,uD) * (-      unsafeIndex (lC,uC) iC + unsafeRangeSize (lC,uC) * (-      unsafeIndex (lB,uB) iB + unsafeRangeSize (lB,uB) * (-      unsafeIndex (lA,uA) iA + unsafeRangeSize (lA,uA) * (-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))))))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD),-             (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9 && inRange (lA,uA) iA &&-      inRange (lB,uB) iB && inRange (lC,uC) iC &&-      inRange (lD,uD) iD--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9,-           Ix aA, Ix aB, Ix aC, Ix aD, Ix aE) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB,aC,aD,aE)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD,lE),-           (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD,uE)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD,iE) | i1 <- range (l1,u1),-                                                     i2 <- range (l2,u2),-                                                     i3 <- range (l3,u3),-                                                     i4 <- range (l4,u4),-                                                     i5 <- range (l5,u5),-                                                     i6 <- range (l6,u6),-                                                     i7 <- range (l7,u7),-                                                     i8 <- range (l8,u8),-                                                     i9 <- range (l9,u9),-                                                     iA <- range (lA,uA),-                                                     iB <- range (lB,uB),-                                                     iC <- range (lC,uC),-                                                     iD <- range (lD,uD),-                                                     iE <- range (lE,uE)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD,lE),-                 (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD,uE))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD,iE) =-      unsafeIndex (lE,uE) iE + unsafeRangeSize (lE,uE) * (-      unsafeIndex (lD,uD) iD + unsafeRangeSize (lD,uD) * (-      unsafeIndex (lC,uC) iC + unsafeRangeSize (lC,uC) * (-      unsafeIndex (lB,uB) iB + unsafeRangeSize (lB,uB) * (-      unsafeIndex (lA,uA) iA + unsafeRangeSize (lA,uA) * (-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1)))))))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD,lE),-             (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD,uE))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD,iE) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9 && inRange (lA,uA) iA &&-      inRange (lB,uB) iB && inRange (lC,uC) iC &&-      inRange (lD,uD) iD && inRange (lE,uE) iE--    -- Default method for index--------------------------------------------------------------------------- | @since 4.15.0.0-instance  (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5, Ix a6, Ix a7, Ix a8, Ix a9,-           Ix aA, Ix aB, Ix aC, Ix aD, Ix aE, Ix aF) =>-      Ix (a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB,aC,aD,aE,aF)  where-    range ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD,lE,lF),-           (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD,uE,uF)) =-      [(i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD,iE,iF) | i1 <- range (l1,u1),-                                                        i2 <- range (l2,u2),-                                                        i3 <- range (l3,u3),-                                                        i4 <- range (l4,u4),-                                                        i5 <- range (l5,u5),-                                                        i6 <- range (l6,u6),-                                                        i7 <- range (l7,u7),-                                                        i8 <- range (l8,u8),-                                                        i9 <- range (l9,u9),-                                                        iA <- range (lA,uA),-                                                        iB <- range (lB,uB),-                                                        iC <- range (lC,uC),-                                                        iD <- range (lD,uD),-                                                        iE <- range (lE,uE),-                                                        iF <- range (lF,uF)]--    unsafeIndex ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD,lE,lF),-                 (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD,uE,uF))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD,iE,iF) =-      unsafeIndex (lF,uF) iF + unsafeRangeSize (lF,uF) * (-      unsafeIndex (lE,uE) iE + unsafeRangeSize (lE,uE) * (-      unsafeIndex (lD,uD) iD + unsafeRangeSize (lD,uD) * (-      unsafeIndex (lC,uC) iC + unsafeRangeSize (lC,uC) * (-      unsafeIndex (lB,uB) iB + unsafeRangeSize (lB,uB) * (-      unsafeIndex (lA,uA) iA + unsafeRangeSize (lA,uA) * (-      unsafeIndex (l9,u9) i9 + unsafeRangeSize (l9,u9) * (-      unsafeIndex (l8,u8) i8 + unsafeRangeSize (l8,u8) * (-      unsafeIndex (l7,u7) i7 + unsafeRangeSize (l7,u7) * (-      unsafeIndex (l6,u6) i6 + unsafeRangeSize (l6,u6) * (-      unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * (-      unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * (-      unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * (-      unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * (-      unsafeIndex (l1,u1) i1))))))))))))))--    inRange ((l1,l2,l3,l4,l5,l6,l7,l8,l9,lA,lB,lC,lD,lE,lF),-             (u1,u2,u3,u4,u5,u6,u7,u8,u9,uA,uB,uC,uD,uE,uF))-        (i1,i2,i3,i4,i5,i6,i7,i8,i9,iA,iB,iC,iD,iE,iF) =-      inRange (l1,u1) i1 && inRange (l2,u2) i2 &&-      inRange (l3,u3) i3 && inRange (l4,u4) i4 &&-      inRange (l5,u5) i5 && inRange (l6,u6) i6 &&-      inRange (l7,u7) i7 && inRange (l8,u8) i8 &&-      inRange (l9,u9) i9 && inRange (lA,uA) iA &&-      inRange (lB,uB) iB && inRange (lC,uC) iC &&-      inRange (lD,uD) iD && inRange (lE,uE) iE &&-      inRange (lF,uF) iF--    -- Default method for index
− GHC/List.hs 
@@ -1,1552 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.List--- 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)------ The List data type and its operations-----------------------------------------------------------------------------------module GHC.List (-   -- [] (..),          -- built-in syntax; can't be used in export list--   map, (++), filter, concat,-   head, last, tail, init, uncons, null, length, (!!),-   foldl, foldl', foldl1, foldl1', scanl, scanl1, scanl', foldr, foldr1,-   scanr, scanr1, iterate, iterate', repeat, replicate, cycle,-   take, drop, sum, product, maximum, minimum, splitAt, takeWhile, dropWhile,-   span, break, reverse, and, or,-   any, all, elem, notElem, lookup,-   concatMap,-   zip, zip3, zipWith, zipWith3, unzip, unzip3,-   errorEmptyList,-- ) where--import Data.Maybe-import GHC.Base-import GHC.Num (Num(..))-import GHC.Num.Integer (Integer)--infixl 9  !!-infix  4 `elem`, `notElem`---- $setup--- >>> import GHC.Base--- >>> import Prelude (Num (..), Ord (..), Int, Double, odd, not, undefined)--- >>> import Control.DeepSeq (force)------ -- compiled versions are uninterruptible.--- https://gitlab.haskell.org/ghc/ghc/-/issues/367------ >>> let or  = foldr (||) False--- >>> let and = foldr (&&) True------------------------------------------------------------------- List-manipulation functions------------------------------------------------------------------- | \(\mathcal{O}(1)\). Extract the first element of a list, which must be non-empty.------ >>> head [1, 2, 3]--- 1--- >>> head [1..]--- 1--- >>> head []--- *** Exception: Prelude.head: empty list-head                    :: [a] -> a-head (x:_)              =  x-head []                 =  badHead-{-# NOINLINE [1] head #-}--badHead :: a-badHead = errorEmptyList "head"---- This rule is useful in cases like---      head [y | (x,y) <- ps, x==t]-{-# RULES-"head/build"    forall (g::forall b.(a->b->b)->b->b) .-                head (build g) = g (\x _ -> x) badHead-"head/augment"  forall xs (g::forall b. (a->b->b) -> b -> b) .-                head (augment g xs) = g (\x _ -> x) (head xs)- #-}---- | \(\mathcal{O}(1)\). Decompose a list into its head and tail.------ * If the list is empty, returns 'Nothing'.--- * If the list is non-empty, returns @'Just' (x, xs)@,--- where @x@ is the head of the list and @xs@ its tail.------ @since 4.8.0.0------ >>> uncons []--- Nothing--- >>> uncons [1]--- Just (1,[])--- >>> uncons [1, 2, 3]--- Just (1,[2,3])-uncons                  :: [a] -> Maybe (a, [a])-uncons []               = Nothing-uncons (x:xs)           = Just (x, xs)---- | \(\mathcal{O}(1)\). Extract the elements after the head of a list, which--- must be non-empty.------ >>> tail [1, 2, 3]--- [2,3]--- >>> tail [1]--- []--- >>> tail []--- *** Exception: Prelude.tail: empty list-tail                    :: [a] -> [a]-tail (_:xs)             =  xs-tail []                 =  errorEmptyList "tail"---- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be--- finite and non-empty.------ >>> last [1, 2, 3]--- 3--- >>> last [1..]--- * Hangs forever *--- >>> last []--- *** Exception: Prelude.last: empty list-last                    :: [a] -> a-#if defined(USE_REPORT_PRELUDE)-last [x]                =  x-last (_:xs)             =  last xs-last []                 =  errorEmptyList "last"-#else--- Use foldl to make last a good consumer.--- This will compile to good code for the actual GHC.List.last.--- (At least as long it is eta-expanded, otherwise it does not, #10260.)-last xs = foldl (\_ x -> x) lastError xs-{-# INLINE last #-}--- The inline pragma is required to make GHC remember the implementation via--- foldl.-lastError :: a-lastError = errorEmptyList "last"-#endif---- | \(\mathcal{O}(n)\). Return all the elements of a list except the last one.--- The list must be non-empty.------ >>> init [1, 2, 3]--- [1,2]--- >>> init [1]--- []--- >>> init []--- *** Exception: Prelude.init: empty list-init                    :: [a] -> [a]-#if defined(USE_REPORT_PRELUDE)-init [x]                =  []-init (x:xs)             =  x : init xs-init []                 =  errorEmptyList "init"-#else--- eliminate repeated cases-init []                 =  errorEmptyList "init"-init (x:xs)             =  init' x xs-  where init' _ []     = []-        init' y (z:zs) = y : init' z zs-#endif---- | \(\mathcal{O}(1)\). Test whether a list is empty.------ >>> null []--- True--- >>> null [1]--- False--- >>> null [1..]--- False-null                    :: [a] -> Bool-null []                 =  True-null (_:_)              =  False---- | \(\mathcal{O}(n)\). 'length' returns the length of a finite list as an--- 'Int'. It is an instance of the more general 'Data.List.genericLength', the--- result type of which may be any kind of number.------ >>> length []--- 0--- >>> length ['a', 'b', 'c']--- 3--- >>> length [1..]--- * Hangs forever *-{-# NOINLINE [1] length #-}-length                  :: [a] -> Int-length xs               = lenAcc xs 0--lenAcc          :: [a] -> Int -> Int-lenAcc []     n = n-lenAcc (_:ys) n = lenAcc ys (n+1)--{-# RULES-"length" [~1] forall xs . length xs = foldr lengthFB idLength xs 0-"lengthList" [1] foldr lengthFB idLength = lenAcc- #-}---- The lambda form turns out to be necessary to make this inline--- when we need it to and give good performance.-{-# INLINE [0] lengthFB #-}-lengthFB :: x -> (Int -> Int) -> Int -> Int-lengthFB _ r = \ !a -> r (a + 1)--{-# INLINE [0] idLength #-}-idLength :: Int -> Int-idLength = id---- | \(\mathcal{O}(n)\). 'filter', applied to a predicate and a list, returns--- the list of those elements that satisfy the predicate; i.e.,------ > filter p xs = [ x | x <- xs, p x]------ >>> filter odd [1, 2, 3]--- [1,3]-{-# NOINLINE [1] filter #-}-filter :: (a -> Bool) -> [a] -> [a]-filter _pred []    = []-filter pred (x:xs)-  | pred x         = x : filter pred xs-  | otherwise      = filter pred xs--{-# INLINE [0] filterFB #-} -- See Note [Inline FB functions]-filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b-filterFB c p x r | p x       = x `c` r-                 | otherwise = r--{-# RULES-"filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr (filterFB c p) n xs)-"filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p-"filterFB"        forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)- #-}---- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.---     filterFB (filterFB c p) q a b---   = if q a then filterFB c p a b else b---   = if q a then (if p a then c a b else b) else b---   = if q a && p a then c a b else b---   = filterFB c (\x -> q x && p x) a b--- I originally wrote (\x -> p x && q x), which is wrong, and actually--- gave rise to a live bug report.  SLPJ.----- | 'foldl', 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------ The list must be finite.------ >>> foldl (+) 0 [1..4]--- 10--- >>> foldl (+) 42 []--- 42--- >>> foldl (-) 100 [1..4]--- 90--- >>> foldl (\reversedString nextChar -> nextChar : reversedString) "foo" ['a', 'b', 'c', 'd']--- "dcbafoo"--- >>> foldl (+) 0 [1..]--- * Hangs forever *-foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b-{-# INLINE foldl #-}-foldl k z0 xs =-  foldr (\(v::a) (fn::b->b) -> oneShot (\(z::b) -> fn (k z v))) (id :: b -> b) xs z0-  -- See Note [Left folds via right fold]--{--Note [Left folds via right fold]--Implementing foldl et. al. via foldr is only a good idea if the compiler can-optimize the resulting code (eta-expand the recursive "go"). See #7994.-We hope that one of the two measure kick in:--   * Call Arity (-fcall-arity, enabled by default) eta-expands it if it can see-     all calls and determine that the arity is large.-   * The oneShot annotation gives a hint to the regular arity analysis that-     it may assume that the lambda is called at most once.-     See [One-shot lambdas] in CoreArity and especially [Eta expanding thunks]-     in CoreArity.--The oneShot annotations used in this module are correct, as we only use them in-arguments to foldr, where we know how the arguments are called.--Note [Inline FB functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~-After fusion rules successfully fire, we are usually left with one or more calls-to list-producing functions abstracted over cons and nil. Here we call them-FB functions because their names usually end with 'FB'. It's a good idea to-inline FB functions because:--* They are higher-order functions and therefore benefit from inlining.--* When the final consumer is a left fold, inlining the FB functions is the only-  way to make arity expansion happen. See Note [Left fold via right fold].--For this reason we mark all FB functions INLINE [0]. The [0] phase-specifier-ensures that calls to FB functions can be written back to the original form-when no fusion happens.--Without these inline pragmas, the loop in perf/should_run/T13001 won't be-allocation-free. Also see #13001.--}---- -------------------------------------------------------------------------------- | A strict version of 'foldl'.-foldl'           :: forall a b . (b -> a -> b) -> b -> [a] -> b-{-# INLINE foldl' #-}-foldl' k z0 xs =-  foldr (\(v::a) (fn::b->b) -> oneShot (\(z::b) -> z `seq` fn (k z v))) (id :: b -> b) xs z0-  -- See Note [Left folds via right fold]---- | 'foldl1' is a variant of 'foldl' that has no starting value argument,--- and thus must be applied to non-empty lists. Note that unlike 'foldl', the accumulated value must be of the same type as the list elements.------ >>> foldl1 (+) [1..4]--- 10--- >>> foldl1 (+) []--- *** Exception: Prelude.foldl1: empty list--- >>> foldl1 (-) [1..4]--- -8--- >>> foldl1 (&&) [True, False, True, True]--- False--- >>> foldl1 (||) [False, False, True, True]--- True--- >>> foldl1 (+) [1..]--- * Hangs forever *-foldl1                  :: (a -> a -> a) -> [a] -> a-foldl1 f (x:xs)         =  foldl f x xs-foldl1 _ []             =  errorEmptyList "foldl1"---- | A strict version of 'foldl1'.-foldl1'                  :: (a -> a -> a) -> [a] -> a-foldl1' f (x:xs)         =  foldl' f x xs-foldl1' _ []             =  errorEmptyList "foldl1'"---- -------------------------------------------------------------------------------- List sum and product---- | The 'sum' function computes the sum of a finite list of numbers.------ >>> sum []--- 0--- >>> sum [42]--- 42--- >>> sum [1..10]--- 55--- >>> sum [4.1, 2.0, 1.7]--- 7.8--- >>> sum [1..]--- * Hangs forever *-sum                     :: (Num a) => [a] -> a-{-# INLINE sum #-}-sum                     =  foldl' (+) 0---- | The 'product' function computes the product of a finite list of numbers.------ >>> product []--- 1--- >>> product [42]--- 42--- >>> product [1..10]--- 3628800--- >>> product [4.1, 2.0, 1.7]--- 13.939999999999998--- >>> product [1..]--- * Hangs forever *-product                 :: (Num a) => [a] -> a-{-# INLINE product #-}-product                 =  foldl' (*) 1---- | \(\mathcal{O}(n)\). 'scanl' is similar to 'foldl', but returns a list 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 (+) 0 [1..4]--- [0,1,3,6,10]--- >>> scanl (+) 42 []--- [42]--- >>> scanl (-) 100 [1..4]--- [100,99,97,94,90]--- >>> scanl (\reversedString nextChar -> nextChar : reversedString) "foo" ['a', 'b', 'c', 'd']--- ["foo","afoo","bafoo","cbafoo","dcbafoo"]--- >>> scanl (+) 0 [1..]--- * Hangs forever *---- This peculiar arrangement is necessary to prevent scanl being rewritten in--- its own right-hand side.-{-# NOINLINE [1] scanl #-}-scanl                   :: (b -> a -> b) -> b -> [a] -> [b]-scanl                   = scanlGo-  where-    scanlGo           :: (b -> a -> b) -> b -> [a] -> [b]-    scanlGo f q ls    = q : (case ls of-                               []   -> []-                               x:xs -> scanlGo f (f q x) xs)---- Note [scanl rewrite rules]-{-# RULES-"scanl"  [~1] forall f a bs . scanl f a bs =-  build (\c n -> a `c` foldr (scanlFB f c) (constScanl n) bs a)-"scanlList" [1] forall f (a::a) bs .-    foldr (scanlFB f (:)) (constScanl []) bs a = tail (scanl f a bs)- #-}--{-# INLINE [0] scanlFB #-} -- See Note [Inline FB functions]-scanlFB :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c-scanlFB f c = \b g -> oneShot (\x -> let b' = f x b in b' `c` g b')-  -- See Note [Left folds via right fold]--{-# INLINE [0] constScanl #-}-constScanl :: a -> b -> a-constScanl = const----- | \(\mathcal{O}(n)\). 'scanl1' is a variant of 'scanl' that has no starting--- value argument:------ > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]------ >>> scanl1 (+) [1..4]--- [1,3,6,10]--- >>> scanl1 (+) []--- []--- >>> scanl1 (-) [1..4]--- [1,-1,-4,-8]--- >>> scanl1 (&&) [True, False, True, True]--- [True,False,False,False]--- >>> scanl1 (||) [False, False, True, True]--- [False,False,True,True]--- >>> scanl1 (+) [1..]--- * Hangs forever *-scanl1                  :: (a -> a -> a) -> [a] -> [a]-scanl1 f (x:xs)         =  scanl f x xs-scanl1 _ []             =  []---- | \(\mathcal{O}(n)\). A strict version of 'scanl'.-{-# NOINLINE [1] scanl' #-}-scanl'           :: (b -> a -> b) -> b -> [a] -> [b]--- This peculiar form is needed to prevent scanl' from being rewritten--- in its own right hand side.-scanl' = scanlGo'-  where-    scanlGo'           :: (b -> a -> b) -> b -> [a] -> [b]-    scanlGo' f !q ls    = q : (case ls of-                            []   -> []-                            x:xs -> scanlGo' f (f q x) xs)---- Note [scanl rewrite rules]-{-# RULES-"scanl'"  [~1] forall f a bs . scanl' f a bs =-  build (\c n -> a `c` foldr (scanlFB' f c) (flipSeqScanl' n) bs a)-"scanlList'" [1] forall f a bs .-    foldr (scanlFB' f (:)) (flipSeqScanl' []) bs a = tail (scanl' f a bs)- #-}--{-# INLINE [0] scanlFB' #-} -- See Note [Inline FB functions]-scanlFB' :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c-scanlFB' f c = \b g -> oneShot (\x -> let !b' = f x b in b' `c` g b')-  -- See Note [Left folds via right fold]--{-# INLINE [0] flipSeqScanl' #-}-flipSeqScanl' :: a -> b -> a-flipSeqScanl' a !_b = a--{--Note [scanl rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~--In most cases, when we rewrite a form to one that can fuse, we try to rewrite it-back to the original form if it does not fuse. For scanl, we do something a-little different. In particular, we rewrite--scanl f a bs--to--build (\c n -> a `c` foldr (scanlFB f c) (constScanl n) bs a)--When build is inlined, this becomes--a : foldr (scanlFB f (:)) (constScanl []) bs a--To rewrite this form back to scanl, we would need a rule that looked like--forall f a bs. a : foldr (scanlFB f (:)) (constScanl []) bs a = scanl f a bs--The problem with this rule is that it has (:) at its head. This would have the-effect of changing the way the inliner looks at (:), not only here but-everywhere.  In most cases, this makes no difference, but in some cases it-causes it to come to a different decision about whether to inline something.-Based on nofib benchmarks, this is bad for performance. Therefore, we instead-match on everything past the :, which is just the tail of scanl.--}---- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the--- above functions.---- | 'foldr1' is a variant of 'foldr' that has no starting value argument,--- and thus must be applied to non-empty lists. Note that unlike 'foldr', the accumulated value must be of the same type as the list elements.------ >>> foldr1 (+) [1..4]--- 10--- >>> foldr1 (+) []--- *** Exception: Prelude.foldr1: empty list--- >>> foldr1 (-) [1..4]--- -2--- >>> foldr1 (&&) [True, False, True, True]--- False--- >>> foldr1 (||) [False, False, True, True]--- True--- >>> force $ foldr1 (+) [1..]--- *** Exception: stack overflow-foldr1                  :: (a -> a -> a) -> [a] -> a-foldr1 f = go-  where go [x]            =  x-        go (x:xs)         =  f x (go xs)-        go []             =  errorEmptyList "foldr1"-{-# INLINE [0] foldr1 #-}---- | \(\mathcal{O}(n)\). 'scanr' is the right-to-left dual of 'scanl'. Note that the order of parameters on the accumulating function are reversed compared to 'scanl'.--- Also note that------ > head (scanr f z xs) == foldr f z xs.------ >>> scanr (+) 0 [1..4]--- [10,9,7,4,0]--- >>> scanr (+) 42 []--- [42]--- >>> scanr (-) 100 [1..4]--- [98,-97,99,-96,100]--- >>> scanr (\nextChar reversedString -> nextChar : reversedString) "foo" ['a', 'b', 'c', 'd']--- ["abcdfoo","bcdfoo","cdfoo","dfoo","foo"]--- >>> force $ scanr (+) 0 [1..]--- *** Exception: stack overflow-{-# NOINLINE [1] scanr #-}-scanr                   :: (a -> b -> b) -> b -> [a] -> [b]-scanr _ q0 []           =  [q0]-scanr f q0 (x:xs)       =  f x q : qs-                           where qs@(q:_) = scanr f q0 xs--{-# INLINE [0] strictUncurryScanr #-}-strictUncurryScanr :: (a -> b -> c) -> (a, b) -> c-strictUncurryScanr f pair = case pair of-                              (x, y) -> f x y--{-# INLINE [0] scanrFB #-} -- See Note [Inline FB functions]-scanrFB :: (a -> b -> b) -> (b -> c -> c) -> a -> (b, c) -> (b, c)-scanrFB f c = \x ~(r, est) -> (f x r, r `c` est)--- This lazy pattern match on the tuple is necessary to prevent--- an infinite loop when scanr receives a fusable infinite list,--- which was the reason for #16943.--- See Note [scanrFB and evaluation] below--{-# RULES-"scanr" [~1] forall f q0 ls . scanr f q0 ls =-  build (\c n -> strictUncurryScanr c (foldr (scanrFB f c) (q0,n) ls))-"scanrList" [1] forall f q0 ls .-               strictUncurryScanr (:) (foldr (scanrFB f (:)) (q0,[]) ls) =-                 scanr f q0 ls- #-}--{- Note [scanrFB and evaluation]-In a previous Version, the pattern match on the tuple in scanrFB used to be-strict. If scanr is called with a build expression, the following would happen:-The rule "scanr" would fire, and we obtain-    build (\c n -> strictUncurryScanr c (foldr (scanrFB f c) (q0,n) (build g))))-The rule "foldr/build" now fires, and the second argument of strictUncurryScanr-will be the expression-    g (scanrFB f c) (q0,n)-which will be evaluated, thanks to strictUncurryScanr.-The type of (g :: (a -> b -> b) -> b -> b) allows us to apply parametricity:-Either the tuple is returned (trivial), or scanrFB is called:-    g (scanrFB f c) (q0,n) = scanrFB ... (g' (scanrFB f c) (q0,n))-Notice that thanks to the strictness of scanrFB, the expression-g' (scanrFB f c) (q0,n) gets evaluated as well. In particular, if g' is a-recursive case of g, parametricity applies again and we will again have a-possible call to scanrFB. In short, g (scanrFB f c) (q0,n) will end up being-completely evaluated. This is resource consuming for large lists and if the-recursion has no exit condition (and this will be the case in functions like-repeat or cycle), the program will crash (see #16943).-The solution: Don't make scanrFB strict in its last argument. Doing so will-remove the cause for the chain of evaluations, and all is well.--}---- | \(\mathcal{O}(n)\). 'scanr1' is a variant of 'scanr' that has no starting--- value argument.------ >>> scanr1 (+) [1..4]--- [10,9,7,4]--- >>> scanr1 (+) []--- []--- >>> scanr1 (-) [1..4]--- [-2,3,-1,4]--- >>> scanr1 (&&) [True, False, True, True]--- [False,False,True,True]--- >>> scanr1 (||) [True, True, False, False]--- [True,True,False,False]--- >>> force $ scanr1 (+) [1..]--- *** Exception: stack overflow-scanr1                  :: (a -> a -> a) -> [a] -> [a]-scanr1 _ []             =  []-scanr1 _ [x]            =  [x]-scanr1 f (x:xs)         =  f x q : qs-                           where qs@(q:_) = scanr1 f xs---- | 'maximum' returns the maximum value from a list,--- which must be non-empty, finite, and of an ordered type.--- It is a special case of 'Data.List.maximumBy', which allows the--- programmer to supply their own comparison function.------ >>> maximum []--- *** Exception: Prelude.maximum: empty list--- >>> maximum [42]--- 42--- >>> maximum [55, -12, 7, 0, -89]--- 55--- >>> maximum [1..]--- * Hangs forever *-maximum                 :: (Ord a) => [a] -> a-{-# INLINABLE maximum #-}-maximum []              =  errorEmptyList "maximum"-maximum 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 []--- *** Exception: Prelude.minimum: empty list--- >>> minimum [42]--- 42--- >>> minimum [55, -12, 7, 0, -89]--- -89--- >>> minimum [1..]--- * Hangs forever *-minimum                 :: (Ord a) => [a] -> a-{-# INLINABLE minimum #-}-minimum []              =  errorEmptyList "minimum"-minimum xs              =  foldl1' min xs--{-# SPECIALIZE  minimum :: [Int] -> Int #-}-{-# SPECIALIZE  minimum :: [Integer] -> Integer #-}----- | 'iterate' @f x@ returns an infinite list of repeated applications--- of @f@ to @x@:------ > iterate f x == [x, f x, f (f x), ...]------ Note that 'iterate' is lazy, potentially leading to thunk build-up if--- the consumer doesn't force each iterate. See 'iterate'' for a strict--- variant of this function.------ >>> take 10 $ iterate not True--- [True,False,True,False...--- >>> take 10 $ iterate (+3) 42--- [42,45,48,51,54,57,60,63...-{-# NOINLINE [1] iterate #-}-iterate :: (a -> a) -> a -> [a]-iterate f x =  x : iterate f (f x)--{-# INLINE [0] iterateFB #-} -- See Note [Inline FB functions]-iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b-iterateFB c f x0 = go x0-  where go x = x `c` go (f x)--{-# RULES-"iterate"    [~1] forall f x.   iterate f x = build (\c _n -> iterateFB c f x)-"iterateFB"  [1]                iterateFB (:) = iterate- #-}----- | 'iterate'' is the strict version of 'iterate'.------ It forces the result of each application of the function to weak head normal--- form (WHNF)--- before proceeding.-{-# NOINLINE [1] iterate' #-}-iterate' :: (a -> a) -> a -> [a]-iterate' f x =-    let x' = f x-    in x' `seq` (x : iterate' f x')--{-# INLINE [0] iterate'FB #-} -- See Note [Inline FB functions]-iterate'FB :: (a -> b -> b) -> (a -> a) -> a -> b-iterate'FB c f x0 = go x0-  where go x =-            let x' = f x-            in x' `seq` (x `c` go x')--{-# RULES-"iterate'"    [~1] forall f x.   iterate' f x = build (\c _n -> iterate'FB c f x)-"iterate'FB"  [1]                iterate'FB (:) = iterate'- #-}----- | 'repeat' @x@ is an infinite list, with @x@ the value of every element.------ >>> take 20 $ repeat 17---[17,17,17,17,17,17,17,17,17...-repeat :: a -> [a]-{-# INLINE [0] repeat #-}--- The pragma just gives the rules more chance to fire-repeat x = xs where xs = x : xs--{-# INLINE [0] repeatFB #-}     -- ditto -- See Note [Inline FB functions]-repeatFB :: (a -> b -> b) -> a -> b-repeatFB c x = xs where xs = x `c` xs---{-# RULES-"repeat"    [~1] forall x. repeat x = build (\c _n -> repeatFB c x)-"repeatFB"  [1]  repeatFB (:)       = repeat- #-}---- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of--- every element.--- It is an instance of the more general 'Data.List.genericReplicate',--- in which @n@ may be of any integral type.------ >>> replicate 0 True--- []--- >>> replicate (-1) True--- []--- >>> replicate 4 True--- [True,True,True,True]-{-# INLINE replicate #-}-replicate               :: Int -> a -> [a]-replicate n x           =  take n (repeat x)---- | 'cycle' ties a finite list into a circular one, or equivalently,--- the infinite repetition of the original list.  It is the identity--- on infinite lists.------ >>> cycle []--- *** Exception: Prelude.cycle: empty list--- >>> take 20 $ cycle [42]--- [42,42,42,42,42,42,42,42,42,42...--- >>> take 20 $ cycle [2, 5, 7]--- [2,5,7,2,5,7,2,5,7,2,5,7...-cycle                   :: [a] -> [a]-cycle []                = errorEmptyList "cycle"-cycle xs                = xs' where xs' = xs ++ xs'---- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the--- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@.------ >>> takeWhile (< 3) [1,2,3,4,1,2,3,4]--- [1,2]--- >>> takeWhile (< 9) [1,2,3]--- [1,2,3]--- >>> takeWhile (< 0) [1,2,3]--- []-{-# NOINLINE [1] takeWhile #-}-takeWhile               :: (a -> Bool) -> [a] -> [a]-takeWhile _ []          =  []-takeWhile p (x:xs)-            | p x       =  x : takeWhile p xs-            | otherwise =  []--{-# INLINE [0] takeWhileFB #-} -- See Note [Inline FB functions]-takeWhileFB :: (a -> Bool) -> (a -> b -> b) -> b -> a -> b -> b-takeWhileFB p c n = \x r -> if p x then x `c` r else n---- The takeWhileFB rule is similar to the filterFB rule. It works like this:--- takeWhileFB q (takeWhileFB p c n) n =--- \x r -> if q x then (takeWhileFB p c n) x r else n =--- \x r -> if q x then (\x' r' -> if p x' then x' `c` r' else n) x r else n =--- \x r -> if q x then (if p x then x `c` r else n) else n =--- \x r -> if q x && p x then x `c` r else n =--- takeWhileFB (\x -> q x && p x) c n-{-# RULES-"takeWhile"     [~1] forall p xs. takeWhile p xs =-                                build (\c n -> foldr (takeWhileFB p c n) n xs)-"takeWhileList" [1]  forall p.    foldr (takeWhileFB p (:) []) [] = takeWhile p-"takeWhileFB"        forall c n p q. takeWhileFB q (takeWhileFB p c n) n =-                        takeWhileFB (\x -> q x && p x) c n- #-}---- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@.------ >>> dropWhile (< 3) [1,2,3,4,5,1,2,3]--- [3,4,5,1,2,3]--- >>> dropWhile (< 9) [1,2,3]--- []--- >>> dropWhile (< 0) [1,2,3]--- [1,2,3]-dropWhile               :: (a -> Bool) -> [a] -> [a]-dropWhile _ []          =  []-dropWhile p xs@(x:xs')-            | p x       =  dropWhile p xs'-            | otherwise =  xs---- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@--- of length @n@, or @xs@ itself if @n >= 'length' xs@.------ >>> take 5 "Hello World!"--- "Hello"--- >>> take 3 [1,2,3,4,5]--- [1,2,3]--- >>> take 3 [1,2]--- [1,2]--- >>> take 3 []--- []--- >>> take (-1) [1,2]--- []--- >>> take 0 [1,2]--- []------ It is an instance of the more general 'Data.List.genericTake',--- in which @n@ may be of any integral type.-take                   :: Int -> [a] -> [a]-#if defined(USE_REPORT_PRELUDE)-take n _      | n <= 0 =  []-take _ []              =  []-take n (x:xs)          =  x : take (n-1) xs-#else--{- We always want to inline this to take advantage of a known length argument-sign. Note, however, that it's important for the RULES to grab take, rather-than trying to INLINE take immediately and then letting the RULES grab-unsafeTake. Presumably the latter approach doesn't grab it early enough; it led-to an allocation regression in nofib/fft2. -}-{-# INLINE [1] take #-}-take n xs | 0 < n     = unsafeTake n xs-          | otherwise = []---- A version of take that takes the whole list if it's given an argument less--- than 1.-{-# NOINLINE [1] unsafeTake #-}-unsafeTake :: Int -> [a] -> [a]-unsafeTake !_  []     = []-unsafeTake 1   (x: _) = [x]-unsafeTake m   (x:xs) = x : unsafeTake (m - 1) xs--{-# RULES-"take"     [~1] forall n xs . take n xs =-  build (\c nil -> if 0 < n-                   then foldr (takeFB c nil) (flipSeqTake nil) xs n-                   else nil)-"unsafeTakeList"  [1] forall n xs . foldr (takeFB (:) []) (flipSeqTake []) xs n-                                        = unsafeTake n xs- #-}--{-# INLINE [0] flipSeqTake #-}--- Just flip seq, specialized to Int, but not inlined too early.--- It's important to force the numeric argument here, even though--- it's not used. Otherwise, take n [] doesn't force n. This is--- bad for strictness analysis and unboxing, and leads to increased--- allocation in T7257.-flipSeqTake :: a -> Int -> a-flipSeqTake x !_n = x--{-# INLINE [0] takeFB #-} -- See Note [Inline FB functions]-takeFB :: (a -> b -> b) -> b -> a -> (Int -> b) -> Int -> b--- The \m accounts for the fact that takeFB is used in a higher-order--- way by takeFoldr, so it's better to inline.  A good example is---     take n (repeat x)--- for which we get excellent code... but only if we inline takeFB--- when given four arguments-takeFB c n x xs-  = \ m -> case m of-            1 -> x `c` n-            _ -> x `c` xs (m - 1)-#endif---- | 'drop' @n xs@ returns the suffix of @xs@--- after the first @n@ elements, or @[]@ if @n >= 'length' xs@.------ >>> drop 6 "Hello World!"--- "World!"--- >>> drop 3 [1,2,3,4,5]--- [4,5]--- >>> drop 3 [1,2]--- []--- >>> drop 3 []--- []--- >>> drop (-1) [1,2]--- [1,2]--- >>> drop 0 [1,2]--- [1,2]------ It is an instance of the more general 'Data.List.genericDrop',--- in which @n@ may be of any integral type.-drop                   :: Int -> [a] -> [a]-#if defined(USE_REPORT_PRELUDE)-drop n xs     | n <= 0 =  xs-drop _ []              =  []-drop n (_:xs)          =  drop (n-1) xs-#else /* hack away */-{-# INLINE drop #-}-drop n ls-  | n <= 0     = ls-  | otherwise  = unsafeDrop n ls-  where-    -- A version of drop that drops the whole list if given an argument-    -- less than 1-    unsafeDrop :: Int -> [a] -> [a]-    unsafeDrop !_ []     = []-    unsafeDrop 1  (_:xs) = xs-    unsafeDrop m  (_:xs) = unsafeDrop (m - 1) xs-#endif---- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of--- length @n@ and second element is the remainder of the list:------ >>> splitAt 6 "Hello World!"--- ("Hello ","World!")--- >>> splitAt 3 [1,2,3,4,5]--- ([1,2,3],[4,5])--- >>> splitAt 1 [1,2,3]--- ([1],[2,3])--- >>> splitAt 3 [1,2,3]--- ([1,2,3],[])--- >>> splitAt 4 [1,2,3]--- ([1,2,3],[])--- >>> splitAt 0 [1,2,3]--- ([],[1,2,3])--- >>> splitAt (-1) [1,2,3]--- ([],[1,2,3])------ It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@--- (@splitAt _|_ xs = _|_@).--- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt',--- in which @n@ may be of any integral type.-splitAt                :: Int -> [a] -> ([a],[a])--#if defined(USE_REPORT_PRELUDE)-splitAt n xs           =  (take n xs, drop n xs)-#else-splitAt n ls-  | n <= 0 = ([], ls)-  | otherwise          = splitAt' n ls-    where-        splitAt' :: Int -> [a] -> ([a], [a])-        splitAt' _  []     = ([], [])-        splitAt' 1  (x:xs) = ([x], xs)-        splitAt' m  (x:xs) = (x:xs', xs'')-          where-            (xs', xs'') = splitAt' (m - 1) xs-#endif /* USE_REPORT_PRELUDE */---- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where--- first element is longest prefix (possibly empty) of @xs@ of elements that--- satisfy @p@ and second element is the remainder of the list:------ >>> span (< 3) [1,2,3,4,1,2,3,4]--- ([1,2],[3,4,1,2,3,4])--- >>> span (< 9) [1,2,3]--- ([1,2,3],[])--- >>> span (< 0) [1,2,3]--- ([],[1,2,3])------ 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@-span                    :: (a -> Bool) -> [a] -> ([a],[a])-span _ xs@[]            =  (xs, xs)-span p xs@(x:xs')-         | p x          =  let (ys,zs) = span p xs' in (x:ys,zs)-         | otherwise    =  ([],xs)---- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where--- first element is longest prefix (possibly empty) of @xs@ of elements that--- /do not satisfy/ @p@ and second element is the remainder of the list:------ >>> break (> 3) [1,2,3,4,1,2,3,4]--- ([1,2,3],[4,1,2,3,4])--- >>> break (< 9) [1,2,3]--- ([],[1,2,3])--- >>> break (> 9) [1,2,3]--- ([1,2,3],[])------ 'break' @p@ is equivalent to @'span' ('not' . p)@.-break                   :: (a -> Bool) -> [a] -> ([a],[a])-#if defined(USE_REPORT_PRELUDE)-break p                 =  span (not . p)-#else--- HBC version (stolen)-break _ xs@[]           =  (xs, xs)-break p xs@(x:xs')-           | p x        =  ([],xs)-           | otherwise  =  let (ys,zs) = break p xs' in (x:ys,zs)-#endif---- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.--- @xs@ must be finite.------ >>> reverse []--- []--- >>> reverse [42]--- [42]--- >>> reverse [2,5,7]--- [7,5,2]--- >>> reverse [1..]--- * Hangs forever *-reverse                 :: [a] -> [a]-#if defined(USE_REPORT_PRELUDE)-reverse                 =  foldl (flip (:)) []-#else-reverse l =  rev l []-  where-    rev []     a = a-    rev (x:xs) a = rev xs (x:a)-#endif---- | 'and' returns the conjunction of a Boolean list. For the result to be--- 'True', the list must be finite; 'False', however, results from a 'False'--- value at a finite index of a finite or infinite list.------ >>> and []--- True--- >>> and [True]--- True--- >>> and [False]--- False--- >>> and [True, True, False]--- False--- >>> and (False : repeat True) -- Infinite list [False,True,True,True,True,True,True...--- False--- >>> and (repeat True)--- * Hangs forever *-and                     :: [Bool] -> Bool-#if defined(USE_REPORT_PRELUDE)-and                     =  foldr (&&) True-#else-and []          =  True-and (x:xs)      =  x && and xs-{-# NOINLINE [1] and #-}--{-# RULES-"and/build"     forall (g::forall b.(Bool->b->b)->b->b) .-                and (build g) = g (&&) True- #-}-#endif---- | 'or' returns the disjunction of a Boolean list. For the result to be--- 'False', the list must be finite; 'True', however, results from a 'True'--- value at a finite index of a finite or infinite list.------ >>> or []--- False--- >>> or [True]--- True--- >>> or [False]--- False--- >>> or [True, True, False]--- True--- >>> or (True : repeat False) -- Infinite list [True,False,False,False,False,False,False...--- True--- >>> or (repeat False)--- * Hangs forever *-or                      :: [Bool] -> Bool-#if defined(USE_REPORT_PRELUDE)-or                      =  foldr (||) False-#else-or []           =  False-or (x:xs)       =  x || or xs-{-# NOINLINE [1] or #-}--{-# RULES-"or/build"      forall (g::forall b.(Bool->b->b)->b->b) .-                or (build g) = g (||) False- #-}-#endif---- | Applied to a predicate and a list, 'any' determines if any element--- of the list satisfies the predicate. For the result to be--- 'False', the list must be finite; 'True', however, results from a 'True'--- value for the predicate applied to an element at a finite index of a finite--- or infinite list.------ >>> any (> 3) []--- False--- >>> any (> 3) [1,2]--- False--- >>> any (> 3) [1,2,3,4,5]--- True--- >>> any (> 3) [1..]--- True--- >>> any (> 3) [0, -1..]--- * Hangs forever *-any                     :: (a -> Bool) -> [a] -> Bool-#if defined(USE_REPORT_PRELUDE)-any p                   =  or . map p-#else-any _ []        = False-any p (x:xs)    = p x || any p xs--{-# NOINLINE [1] any #-}--{-# RULES-"any/build"     forall p (g::forall b.(a->b->b)->b->b) .-                any p (build g) = g ((||) . p) False- #-}-#endif---- | Applied to a predicate and a list, 'all' determines if all elements--- of the list satisfy the predicate. For the result to be--- 'True', the list must be finite; 'False', however, results from a 'False'--- value for the predicate applied to an element at a finite index of a finite--- or infinite list.------ >>> all (> 3) []--- True--- >>> all (> 3) [1,2]--- False--- >>> all (> 3) [1,2,3,4,5]--- False--- >>> all (> 3) [1..]--- False--- >>> all (> 3) [4..]--- * Hangs forever *-all                     :: (a -> Bool) -> [a] -> Bool-#if defined(USE_REPORT_PRELUDE)-all p                   =  and . map p-#else-all _ []        =  True-all p (x:xs)    =  p x && all p xs--{-# NOINLINE [1] all #-}--{-# RULES-"all/build"     forall p (g::forall b.(a->b->b)->b->b) .-                all p (build g) = g ((&&) . p) True- #-}-#endif---- | 'elem' is the list membership predicate, usually written in infix form,--- e.g., @x \`elem\` xs@.  For the result to be--- 'False', the list must be finite; 'True', however, results from an element--- equal to @x@ found at a finite index of a finite or infinite list.------ >>> 3 `elem` []--- False--- >>> 3 `elem` [1,2]--- False--- >>> 3 `elem` [1,2,3,4,5]--- True--- >>> 3 `elem` [1..]--- True--- >>> 3 `elem` [4..]--- * Hangs forever *-elem                    :: (Eq a) => a -> [a] -> Bool-#if defined(USE_REPORT_PRELUDE)-elem x                  =  any (== x)-#else-elem _ []       = False-elem x (y:ys)   = x==y || elem x ys-{-# NOINLINE [1] elem #-}-{-# RULES-"elem/build"    forall x (g :: forall b . (a -> b -> b) -> b -> b)-   . elem x (build g) = g (\ y r -> (x == y) || r) False- #-}-#endif---- | 'notElem' is the negation of 'elem'.------ >>> 3 `notElem` []--- True--- >>> 3 `notElem` [1,2]--- True--- >>> 3 `notElem` [1,2,3,4,5]--- False--- >>> 3 `notElem` [1..]--- False--- >>> 3 `notElem` [4..]--- * Hangs forever *-notElem                 :: (Eq a) => a -> [a] -> Bool-#if defined(USE_REPORT_PRELUDE)-notElem x               =  all (/= x)-#else-notElem _ []    =  True-notElem x (y:ys)=  x /= y && notElem x ys-{-# NOINLINE [1] notElem #-}-{-# RULES-"notElem/build" forall x (g :: forall b . (a -> b -> b) -> b -> b)-   . notElem x (build g) = g (\ y r -> (x /= y) && r) True- #-}-#endif---- | \(\mathcal{O}(n)\). 'lookup' @key assocs@ looks up a key in an association--- list.------ >>> lookup 2 []--- Nothing--- >>> lookup 2 [(1, "first")]--- Nothing--- >>> lookup 2 [(1, "first"), (2, "second"), (3, "third")]--- Just "second"-lookup                  :: (Eq a) => a -> [(a,b)] -> Maybe b-lookup _key []          =  Nothing-lookup  key ((x,y):xys)-    | key == x           =  Just y-    | otherwise         =  lookup key xys---- | Map a function returning a list over a list and concatenate the results.--- 'concatMap' can be seen as the composition of 'concat' and 'map'.------ > concatMap f xs == (concat . map f) xs------ >>> concatMap (\i -> [-i,i]) []--- []--- >>> concatMap (\i -> [-i,i]) [1,2,3]--- [-1,1,-2,2,-3,3]-concatMap               :: (a -> [b]) -> [a] -> [b]-concatMap f             =  foldr ((++) . f) []--{-# NOINLINE [1] concatMap #-}--{-# RULES-"concatMap" forall f xs . concatMap f xs =-    build (\c n -> foldr (\x b -> foldr c b (f x)) n xs)- #-}----- | Concatenate a list of lists.------ >>> concat []--- []--- >>> concat [[42]]--- [42]--- >>> concat [[1,2,3], [4,5], [6], []]--- [1,2,3,4,5,6]-concat :: [[a]] -> [a]-concat = foldr (++) []--{-# NOINLINE [1] concat #-}--{-# RULES-  "concat" forall xs. concat xs =-     build (\c n -> foldr (\x y -> foldr c y x) n xs)--- We don't bother to turn non-fusible applications of concat back into concat- #-}---- | List index (subscript) operator, starting from 0.--- It is an instance of the more general 'Data.List.genericIndex',--- which takes an index of any integral type.------ >>> ['a', 'b', 'c'] !! 0--- 'a'--- >>> ['a', 'b', 'c'] !! 2--- 'c'--- >>> ['a', 'b', 'c'] !! 3--- *** Exception: Prelude.!!: index too large--- >>> ['a', 'b', 'c'] !! (-1)--- *** Exception: Prelude.!!: negative index-(!!)                    :: [a] -> Int -> a-#if defined(USE_REPORT_PRELUDE)-xs     !! n | n < 0 =  errorWithoutStackTrace "Prelude.!!: negative index"-[]     !! _         =  errorWithoutStackTrace "Prelude.!!: index too large"-(x:_)  !! 0         =  x-(_:xs) !! n         =  xs !! (n-1)-#else---- We don't really want the errors to inline with (!!).--- We may want to fuss around a bit with NOINLINE, and--- if so we should be careful not to trip up known-bottom--- optimizations.-tooLarge :: Int -> a-tooLarge _ = errorWithoutStackTrace (prel_list_str ++ "!!: index too large")--negIndex :: a-negIndex = errorWithoutStackTrace $ prel_list_str ++ "!!: negative index"--{-# INLINABLE (!!) #-}-xs !! n-  | n < 0     = negIndex-  | otherwise = foldr (\x r k -> case k of-                                   0 -> x-                                   _ -> r (k-1)) tooLarge xs n-#endif------------------------------------------------------------------- The zip family-----------------------------------------------------------------foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c-foldr2 k z = go-  where-        go []    _ys     = z-        go _xs   []      = z-        go (x:xs) (y:ys) = k x y (go xs ys)-{-# INLINE [0] foldr2 #-}  -- See Note [Fusion for foldrN]--foldr2_left :: (a -> b -> c -> d) -> d -> a -> ([b] -> c) -> [b] -> d-foldr2_left _k  z _x _r []     = z-foldr2_left  k _z  x  r (y:ys) = k x y (r ys)---- foldr2 k z xs ys = foldr (foldr2_left k z)  (\_ -> z) xs ys-{-# RULES   -- See Note [Fusion for foldrN]-"foldr2/left"   forall k z ys (g::forall b.(a->b->b)->b->b) .-                  foldr2 k z (build g) ys = g (foldr2_left  k z) (\_ -> z) ys- #-}--foldr3 :: (a -> b -> c -> d -> d) -> d -> [a] -> [b] -> [c] -> d-foldr3 k z = go-  where-    go  []    _      _      = z-    go  _     []     _      = z-    go  _     _      []     = z-    go (a:as) (b:bs) (c:cs) = k a b c (go as bs cs)-{-# INLINE [0] foldr3 #-}  -- See Note [Fusion for foldrN]---foldr3_left :: (a -> b -> c -> d -> e) -> e -> a ->-               ([b] -> [c] -> d) -> [b] -> [c] -> e-foldr3_left k _z a r (b:bs) (c:cs) = k a b c (r bs cs)-foldr3_left _  z _ _  _      _     = z---- foldr3 k n xs ys zs = foldr (foldr3_left k n) (\_ _ -> n) xs ys zs-{-# RULES   -- See Note [Fusion for foldrN]-"foldr3/left"   forall k z (g::forall b.(a->b->b)->b->b).-                  foldr3 k z (build g) = g (foldr3_left k z) (\_ _ -> z)- #-}--{- Note [Fusion for foldrN]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We arrange that foldr2, foldr3, etc is a good consumer for its first-(left) list argument. Here's how. See below for the second, third-etc list arguments--* The rule "foldr2/left" (active only before phase 1) does this:-     foldr2 k z (build g) ys = g (foldr2_left  k z) (\_ -> z) ys-  thereby fusing away the 'build' on the left argument--* To ensure this rule has a chance to fire, foldr2 has a NOINLINE[1] pragma--There used to be a "foldr2/right" rule, allowing foldr2 to fuse with a build-form on the right. However, this causes trouble if the right list ends in-a bottom that is only avoided by the left list ending at that spot. That is,-foldr2 f z [a,b,c] (d:e:f:_|_), where the right list is produced by a build-form, would cause the foldr2/right rule to introduce bottom. Example:-  zip [1,2,3,4] (unfoldr (\s -> if s > 4 then undefined else Just (s,s+1)) 1)-should produce-  [(1,1),(2,2),(3,3),(4,4)]-but with the foldr2/right rule it would instead produce-  (1,1):(2,2):(3,3):(4,4):_|_--Note [Fusion for zipN/zipWithN]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We arrange that zip, zip3, etc, and zipWith, zipWit3 etc, are all-good consumers for their first (left) argument, and good producers.-Here's how.  See Note [Fusion for foldr2] for why it can't fuse its-second (right) list argument.--NB: Zips for larger tuples are in the List module.--* Rule "zip" (active only before phase 1) rewrites-    zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)-  See also Note [Inline FB functions]--  Ditto rule "zipWith".--* To give this rule a chance to fire, we give zip a NOLINLINE[1]-  pragma (although since zip is recursive it might not need it)--* Now the rules for foldr2 (see Note [Fusion for foldr2]) may fire,-  or rules that fuse the build-produced output of zip.--* If none of these fire, rule "zipList" (active only in phase 1)-  rewrites the foldr2 call back to zip-     foldr2 (zipFB (:)) []   = zip-  This rule will only fire when build has inlined, which also-  happens in phase 1.--  Ditto rule "zipWithList".--}--------------------------------------------------- | \(\mathcal{O}(\min(m,n))\). 'zip' takes two lists and returns a list of--- corresponding pairs.------ >>> zip [1, 2] ['a', 'b']--- [(1,'a'),(2,'b')]------ If one input list is shorter than the other, excess elements of the longer--- list are discarded, even if one of the lists is infinite:------ >>> zip [1] ['a', 'b']--- [(1,'a')]--- >>> zip [1, 2] ['a']--- [(1,'a')]--- >>> zip [] [1..]--- []--- >>> zip [1..] []--- []------ 'zip' is right-lazy:------ >>> zip [] undefined--- []--- >>> zip undefined []--- *** Exception: Prelude.undefined--- ...------ 'zip' is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zip #-}  -- See Note [Fusion for zipN/zipWithN]-zip :: [a] -> [b] -> [(a,b)]-zip []     _bs    = []-zip _as    []     = []-zip (a:as) (b:bs) = (a,b) : zip as bs--{-# INLINE [0] zipFB #-} -- See Note [Inline FB functions]-zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d-zipFB c = \x y r -> (x,y) `c` r--{-# RULES  -- See Note [Fusion for zipN/zipWithN]-"zip"      [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)-"zipList"  [1]  foldr2 (zipFB (:)) []   = zip- #-}--------------------------------------------------- | 'zip3' takes three lists and returns a list of triples, analogous to--- 'zip'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zip3 #-}-zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]--- Specification--- zip3 =  zipWith3 (,,)-zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs-zip3 _      _      _      = []--{-# INLINE [0] zip3FB #-} -- See Note [Inline FB functions]-zip3FB :: ((a,b,c) -> xs -> xs') -> a -> b -> c -> xs -> xs'-zip3FB cons = \a b c r -> (a,b,c) `cons` r--{-# RULES    -- See Note [Fusion for zipN/zipWithN]-"zip3"       [~1] forall as bs cs. zip3 as bs cs = build (\c n -> foldr3 (zip3FB c) n as bs cs)-"zip3List"   [1]          foldr3 (zip3FB (:)) [] = zip3- #-}---- The zipWith family generalises the zip family by zipping with the--- function given as the first argument, instead of a tupling function.--------------------------------------------------- | \(\mathcal{O}(\min(m,n))\). 'zipWith' generalises 'zip' by zipping with the--- function given as the first argument, instead of a tupling function.------ > zipWith (,) xs ys == zip xs ys--- > zipWith f [x1,x2,x3..] [y1,y2,y3..] == [f x1 y1, f x2 y2, f x3 y3..]------ For example, @'zipWith' (+)@ is applied to two lists to produce the list of--- corresponding sums:------ >>> zipWith (+) [1, 2, 3] [4, 5, 6]--- [5,7,9]------ 'zipWith' is right-lazy:------ >>> let f = undefined--- >>> zipWith f [] undefined--- []------ 'zipWith' is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.-{-# NOINLINE [1] zipWith #-}  -- See Note [Fusion for zipN/zipWithN]-zipWith :: (a->b->c) -> [a]->[b]->[c]-zipWith f = go-  where-    go [] _ = []-    go _ [] = []-    go (x:xs) (y:ys) = f x y : go xs ys---- zipWithFB must have arity 2 since it gets two arguments in the "zipWith"--- rule; it might not get inlined otherwise-{-# INLINE [0] zipWithFB #-} -- See Note [Inline FB functions]-zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c-zipWithFB c f = \x y r -> (x `f` y) `c` r--{-# RULES       -- See Note [Fusion for zipN/zipWithN]-"zipWith"       [~1] forall f xs ys.    zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)-"zipWithList"   [1]  forall f.  foldr2 (zipWithFB (:) f) [] = zipWith f-  #-}---- | The 'zipWith3' function takes a function which combines three--- elements, as well as three lists and returns a list of the function applied--- to corresponding elements, analogous to 'zipWith'.--- It is capable of list fusion, but it is restricted to its--- first list argument and its resulting list.------ > zipWith3 (,,) xs ys zs == zip3 xs ys zs--- > zipWith3 f [x1,x2,x3..] [y1,y2,y3..] [z1,z2,z3..] == [f x1 y1 z1, f x2 y2 z2, f x3 y3 z3..]-{-# NOINLINE [1] zipWith3 #-}-zipWith3                :: (a->b->c->d) -> [a]->[b]->[c]->[d]-zipWith3 z = go-  where-    go (a:as) (b:bs) (c:cs) = z a b c : go as bs cs-    go _ _ _                = []--{-# INLINE [0] zipWith3FB #-} -- See Note [Inline FB functions]-zipWith3FB :: (d -> xs -> xs') -> (a -> b -> c -> d) -> a -> b -> c -> xs -> xs'-zipWith3FB cons func = \a b c r -> (func a b c) `cons` r--{-# RULES-"zipWith3"      [~1] forall f as bs cs.   zipWith3 f as bs cs = build (\c n -> foldr3 (zipWith3FB c f) n as bs cs)-"zipWith3List"  [1]  forall f.   foldr3 (zipWith3FB (:) f) [] = zipWith3 f- #-}---- | 'unzip' transforms a list of pairs into a list of first components--- and a list of second components.------ >>> unzip []--- ([],[])--- >>> unzip [(1, 'a'), (2, 'b')]--- ([1,2],"ab")-unzip    :: [(a,b)] -> ([a],[b])-{-# INLINE unzip #-}--- Inline so that fusion `foldr` has an opportunity to fire.--- See Note [Inline @unzipN@ functions] in GHC/OldList.hs.-unzip    =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])---- | The 'unzip3' function takes a list of triples and returns three--- lists, analogous to 'unzip'.------ >>> unzip3 []--- ([],[],[])--- >>> unzip3 [(1, 'a', True), (2, 'b', False)]--- ([1,2],"ab",[True,False])-unzip3   :: [(a,b,c)] -> ([a],[b],[c])-{-# INLINE unzip3 #-}--- Inline so that fusion `foldr` has an opportunity to fire.--- See Note [Inline @unzipN@ functions] in GHC/OldList.hs.-unzip3   =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))-                  ([],[],[])------------------------------------------------------------------- Error code------------------------------------------------------------------- Common up near identical calls to `error' to reduce the number--- constant strings created when compiled:--errorEmptyList :: String -> a-errorEmptyList fun =-  errorWithoutStackTrace (prel_list_str ++ fun ++ ": empty list")--prel_list_str :: String-prel_list_str = "Prelude."
− GHC/MVar.hs 
@@ -1,182 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.MVar--- Copyright   :  (c) The University of Glasgow 2008--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The MVar type-----------------------------------------------------------------------------------module GHC.MVar (-        -- * MVars-          MVar(..)-        , newMVar-        , newEmptyMVar-        , takeMVar-        , readMVar-        , putMVar-        , tryTakeMVar-        , tryPutMVar-        , tryReadMVar-        , isEmptyMVar-        , addMVarFinalizer-    ) where--import GHC.Base--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-as a box, which may be empty or full.--}---- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module--- | @since 4.1.0.0-instance Eq (MVar a) where-        (MVar mvar1#) == (MVar mvar2#) = isTrue# (sameMVar# mvar1# mvar2#)--{--M-Vars are rendezvous points for concurrent threads.  They begin-empty, and any attempt to read an empty M-Var blocks.  When an M-Var-is written, a single blocked thread may be freed.  Reading an M-Var-toggles its state from full back to empty.  Therefore, any value-written to an M-Var may only be read once.  Multiple reads and writes-are allowed, but there must be at least one read between any two-writes.--}----Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)---- |Create an 'MVar' which is initially empty.-newEmptyMVar  :: IO (MVar a)-newEmptyMVar = IO $ \ s# ->-    case newMVar# s# of-         (# s2#, svar# #) -> (# s2#, MVar svar# #)---- |Create an 'MVar' which contains the supplied value.-newMVar :: a -> IO (MVar a)-newMVar value =-    newEmptyMVar        >>= \ mvar ->-    putMVar mvar value  >>-    return mvar---- |Return the contents of the 'MVar'.  If the 'MVar' is currently--- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',--- the 'MVar' is left empty.------ There are two further important properties of 'takeMVar':------   * 'takeMVar' is single-wakeup.  That is, if there are multiple---     threads blocked in 'takeMVar', and the 'MVar' becomes full,---     only one thread will be woken up.  The runtime guarantees that---     the woken thread completes its 'takeMVar' operation.------   * When multiple threads are blocked on an 'MVar', they are---     woken up in FIFO order.  This is useful for providing---     fairness properties of abstractions built using 'MVar's.----takeMVar :: MVar a -> IO a-takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#---- |Atomically read the contents of an 'MVar'.  If the 'MVar' is--- currently empty, 'readMVar' will wait until it is full.--- 'readMVar' is guaranteed to receive the next 'putMVar'.------ 'readMVar' is multiple-wakeup, so when multiple readers are--- blocked on an 'MVar', all of them are woken up at the same time.------ /Compatibility note:/ Prior to base 4.7, 'readMVar' was a combination--- of 'takeMVar' and 'putMVar'.  This mean that in the presence of--- other threads attempting to 'putMVar', 'readMVar' could block.--- Furthermore, 'readMVar' would not receive the next 'putMVar' if there--- was already a pending thread blocked on 'takeMVar'.  The old behavior--- can be recovered by implementing 'readMVar as follows:------ @---  readMVar :: MVar a -> IO a---  readMVar m =---    mask_ $ do---      a <- takeMVar m---      putMVar m a---      return a--- @-readMVar :: MVar a -> IO a-readMVar (MVar mvar#) = IO $ \ s# -> readMVar# mvar# s#---- |Put a value into an 'MVar'.  If the 'MVar' is currently full,--- 'putMVar' will wait until it becomes empty.------ There are two further important properties of 'putMVar':------   * 'putMVar' is single-wakeup.  That is, if there are multiple---     threads blocked in 'putMVar', and the 'MVar' becomes empty,---     only one thread will be woken up.  The runtime guarantees that---     the woken thread completes its 'putMVar' operation.------   * When multiple threads are blocked on an 'MVar', they are---     woken up in FIFO order.  This is useful for providing---     fairness properties of abstractions built using 'MVar's.----putMVar  :: MVar a -> a -> IO ()-putMVar (MVar mvar#) x = IO $ \ s# ->-    case putMVar# mvar# x s# of-        s2# -> (# s2#, () #)---- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function--- returns immediately, with 'Nothing' if the 'MVar' was empty, or--- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',--- the 'MVar' is left empty.-tryTakeMVar :: MVar a -> IO (Maybe a)-tryTakeMVar (MVar m) = IO $ \ s ->-    case tryTakeMVar# m s of-        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty-        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full---- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function--- attempts to put the value @a@ into the 'MVar', returning 'True' if--- it was successful, or 'False' otherwise.-tryPutMVar  :: MVar a -> a -> IO Bool-tryPutMVar (MVar mvar#) x = IO $ \ s# ->-    case tryPutMVar# mvar# x s# of-        (# s, 0# #) -> (# s, False #)-        (# s, _  #) -> (# s, True #)---- |A non-blocking version of 'readMVar'.  The 'tryReadMVar' function--- returns immediately, with 'Nothing' if the 'MVar' was empty, or--- @'Just' a@ if the 'MVar' was full with contents @a@.------ @since 4.7.0.0-tryReadMVar :: MVar a -> IO (Maybe a)-tryReadMVar (MVar m) = IO $ \ s ->-    case tryReadMVar# m s of-        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty-        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full---- |Check whether a given 'MVar' is empty.------ Notice that the boolean value returned  is just a snapshot of--- the state of the MVar. By the time you get to react on its result,--- the MVar may have been filled (or emptied) - so be extremely--- careful when using this operation.   Use 'tryTakeMVar' instead if possible.-isEmptyMVar :: MVar a -> IO Bool-isEmptyMVar (MVar mv#) = IO $ \ s# ->-    case isEmptyMVar# mv# s# of-        (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)---- |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) (IO finalizer) =-    IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }-
− GHC/Maybe.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}---- | Maybe type-module GHC.Maybe-   ( Maybe (..)-   )-where--import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base-import GHC.Classes--default ()------------------------------------------------------------------------------------ Maybe type------------------------------------------------------------------------------------ | The 'Maybe' type encapsulates an optional value.  A value of type--- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@),--- or it is empty (represented as 'Nothing').  Using 'Maybe' is a good way to--- deal with errors or exceptional cases without resorting to drastic--- measures such as 'Prelude.error'.------ The 'Maybe' type is also a monad.  It is a simple kind of error--- monad, where all errors are represented by 'Nothing'.  A richer--- error monad can be built using the 'Data.Either.Either' type.----data  Maybe a  =  Nothing | Just a-  deriving ( Eq  -- ^ @since 2.01-           , Ord -- ^ @since 2.01-           )
− GHC/Natural.hs 
@@ -1,189 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE UnboxedSums #-}--{-# OPTIONS_HADDOCK not-home #-}---- | Compatibility module for pre ghc-bignum code.-module GHC.Natural-   ( Natural (NatS#, NatJ#)-   , B.BigNat (..)-   , mkNatural-   , isValidNatural-     -- * Arithmetic-   , plusNatural-   , minusNatural-   , minusNaturalMaybe-   , timesNatural-   , negateNatural-   , signumNatural-   , quotRemNatural-   , quotNatural-   , remNatural-   , gcdNatural-   , lcmNatural-     -- * Bits-   , andNatural-   , orNatural-   , xorNatural-   , bitNatural-   , testBitNatural-   , popCountNatural-   , shiftLNatural-   , shiftRNatural-     -- * Conversions-   , naturalToInteger-   , naturalToWord-   , naturalToWordMaybe-   , wordToNatural-   , wordToNatural#-   , naturalFromInteger-     -- * Modular arithmetic-   , powModNatural-   )-where--import GHC.Prim-import GHC.Types-import GHC.Maybe-import GHC.Num.Natural (Natural)-import GHC.Num.Integer (Integer)-import qualified GHC.Num.BigNat  as B-import qualified GHC.Num.Natural as N-import qualified GHC.Num.Integer as I--{-# COMPLETE NatS#, NatJ# #-}--pattern NatS# :: Word# -> Natural-pattern NatS# w = N.NS w--pattern NatJ# :: B.BigNat -> Natural-pattern NatJ# b <- N.NB (B.BN# -> b)-   where-      NatJ# b = N.NB (B.unBigNat b)--int2Word :: Int -> Word-int2Word (I# i) = W# (int2Word# i)--word2Int :: Word -> Int-word2Int (W# w) = I# (word2Int# w)---- | Construct 'Natural' value from list of 'Word's.-mkNatural :: [Word] -> Natural-mkNatural = N.naturalFromWordList---- | Test whether all internal invariants are satisfied by 'Natural' value------ This operation is mostly useful for test-suites and/or code which--- constructs 'Integer' values directly.------ @since 4.8.0.0-isValidNatural :: Natural -> Bool-isValidNatural = N.naturalCheck---- | 'Natural' Addition-plusNatural :: Natural -> Natural -> Natural-plusNatural = N.naturalAdd---- | 'Natural' subtraction. May @'Control.Exception.throw'--- 'Control.Exception.Underflow'@.-minusNatural :: Natural -> Natural -> Natural-minusNatural = N.naturalSubThrow---- | 'Natural' subtraction. Returns 'Nothing's for non-positive results.------ @since 4.8.0.0-minusNaturalMaybe :: Natural -> Natural -> Maybe Natural-minusNaturalMaybe x y = case N.naturalSub x y of-   (# (# #) |   #) -> Nothing-   (#       | n #) -> Just n---- | 'Natural' multiplication-timesNatural :: Natural -> Natural -> Natural-timesNatural = N.naturalMul--negateNatural :: Natural -> Natural-negateNatural = N.naturalNegate--signumNatural :: Natural -> Natural-signumNatural = N.naturalSignum--quotRemNatural :: Natural -> Natural -> (Natural, Natural)-quotRemNatural = N.naturalQuotRem--remNatural :: Natural -> Natural -> Natural-remNatural = N.naturalRem--quotNatural :: Natural -> Natural -> Natural-quotNatural = N.naturalQuot---- | Compute greatest common divisor.-gcdNatural :: Natural -> Natural -> Natural-gcdNatural = N.naturalGcd---- | Compute least common multiple.-lcmNatural :: Natural -> Natural -> Natural-lcmNatural = N.naturalLcm--andNatural :: Natural -> Natural -> Natural-andNatural = N.naturalAnd--orNatural :: Natural -> Natural -> Natural-orNatural = N.naturalOr--xorNatural :: Natural -> Natural -> Natural-xorNatural = N.naturalXor--bitNatural :: Int# -> Natural-bitNatural i = N.naturalBit# (int2Word# i)--testBitNatural :: Natural -> Int -> Bool-testBitNatural n i = N.naturalTestBit n (int2Word i)--popCountNatural :: Natural -> Int-popCountNatural n = word2Int (N.naturalPopCount n)--shiftLNatural :: Natural -> Int -> Natural-shiftLNatural n i = N.naturalShiftL n (int2Word  i)--shiftRNatural :: Natural -> Int -> Natural-shiftRNatural n i = N.naturalShiftR n (int2Word i)---- | @since 4.12.0.0-naturalToInteger :: Natural -> Integer-naturalToInteger = I.integerFromNatural--naturalToWord :: Natural -> Word-naturalToWord = N.naturalToWord---- | @since 4.10.0.0-naturalFromInteger :: Integer -> Natural-naturalFromInteger = I.integerToNatural---- | Construct 'Natural' from 'Word' value.------ @since 4.8.0.0-wordToNatural :: Word -> Natural-wordToNatural = N.naturalFromWord---- | Try downcasting 'Natural' to 'Word' value.--- Returns 'Nothing' if value doesn't fit in 'Word'.------ @since 4.8.0.0-naturalToWordMaybe :: Natural -> Maybe Word-naturalToWordMaybe n = case N.naturalToWordMaybe# n of-   (#       | w #) -> Just (W# w)-   (# (# #) |   #) -> Nothing--wordToNatural# :: Word -> Natural-wordToNatural# = N.naturalFromWord---- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to--- exponent @/e/@ modulo @/m/@.------ @since 4.8.0.0-powModNatural :: Natural -> Natural -> Natural -> Natural-powModNatural = N.naturalPowMod
− GHC/Num.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Num--- 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)------ The 'Num' class and the 'Integer' type.------------------------------------------------------------------------------------module GHC.Num-   ( module GHC.Num-   , module GHC.Num.Integer-   , module GHC.Num.Natural-    -- reexported for backward compatibility-   , module GHC.Natural-   , module GHC.Integer-   )-where--#include "MachDeps.h"--import qualified GHC.Natural-import qualified GHC.Integer--import GHC.Base-import GHC.Num.Integer-import GHC.Num.Natural--infixl 7  *-infixl 6  +, ---default ()              -- Double isn't available yet,-                        -- and we shouldn't be using defaults anyway---- | Basic numeric class.------ The Haskell Report defines no laws for 'Num'. However, @('+')@ and @('*')@ are--- customarily expected to define a ring and have the following properties:------ [__Associativity of @('+')@__]: @(x + y) + z@ = @x + (y + z)@--- [__Commutativity of @('+')@__]: @x + y@ = @y + x@--- [__@'fromInteger' 0@ is the additive identity__]: @x + fromInteger 0@ = @x@--- [__'negate' gives the additive inverse__]: @x + negate x@ = @fromInteger 0@--- [__Associativity of @('*')@__]: @(x * y) * z@ = @x * (y * z)@--- [__@'fromInteger' 1@ is the multiplicative identity__]:--- @x * fromInteger 1@ = @x@ and @fromInteger 1 * x@ = @x@--- [__Distributivity of @('*')@ with respect to @('+')@__]:--- @a * (b + c)@ = @(a * b) + (a * c)@ and @(b + c) * a@ = @(b * a) + (c * a)@------ Note that it /isn't/ customarily expected that a type instance of both 'Num'--- and 'Ord' implement an ordered ring. Indeed, in @base@ only 'Integer' and--- 'Data.Ratio.Rational' do.-class  Num a  where-    {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-}--    (+), (-), (*)       :: a -> a -> a-    -- | Unary negation.-    negate              :: a -> a-    -- | Absolute value.-    abs                 :: a -> a-    -- | Sign of a number.-    -- The functions 'abs' and 'signum' should satisfy the law:-    ---    -- > abs x * signum x == x-    ---    -- For real numbers, the 'signum' is either @-1@ (negative), @0@ (zero)-    -- or @1@ (positive).-    signum              :: a -> a-    -- | Conversion from an 'Integer'.-    -- An integer literal represents the application of the function-    -- 'fromInteger' to the appropriate value of type 'Integer',-    -- so such literals have type @('Num' a) => a@.-    fromInteger         :: Integer -> a--    {-# INLINE (-) #-}-    {-# INLINE negate #-}-    x - y               = x + negate y-    negate x            = 0 - x---- | the same as @'flip' ('-')@.------ Because @-@ is treated specially in the Haskell grammar,--- @(-@ /e/@)@ is not a section, but an application of prefix negation.--- However, @('subtract'@ /exp/@)@ is equivalent to the disallowed section.-{-# INLINE subtract #-}-subtract :: (Num a) => a -> a -> a-subtract x y = y - x---- | @since 2.01-instance Num Int where-    I# x + I# y = I# (x +# y)-    I# x - I# y = I# (x -# y)-    negate (I# x) = I# (negateInt# x)-    I# x * I# y = I# (x *# y)-    abs n  = if n `geInt` 0 then n else negate n--    signum n | n `ltInt` 0 = negate 1-             | n `eqInt` 0 = 0-             | otherwise   = 1--    fromInteger i = I# (integerToInt# i)---- | @since 2.01-instance Num Word where-    (W# x#) + (W# y#)      = W# (x# `plusWord#` y#)-    (W# x#) - (W# y#)      = W# (x# `minusWord#` y#)-    (W# x#) * (W# y#)      = W# (x# `timesWord#` y#)-    negate (W# x#)         = W# (int2Word# (negateInt# (word2Int# x#)))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W# (integerToWord# i)---- | @since 2.01-instance Num Integer where-    (+) = integerAdd-    (-) = integerSub-    (*) = integerMul-    negate         = integerNegate-    fromInteger i  = i--    abs    = integerAbs-    signum = integerSignum---- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an--- additive inverse. It is a semiring though.------ @since 4.8.0.0-instance Num Natural where-    (+)         = naturalAdd-    (-)         = naturalSubThrow-    (*)         = naturalMul-    negate      = naturalNegate-    fromInteger i = integerToNaturalThrow i-    abs         = id-    signum      = naturalSignum--{-# DEPRECATED quotRemInteger "Use integerQuotRem# instead" #-}-quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)-quotRemInteger = integerQuotRem#-
− GHC/OldList.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.OldList--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ This legacy module provides access to the list-specialised operations--- of "Data.List". This module may go away again in future GHC versions and--- is provided as transitional tool to access some of the list-specialised--- operations that had to be generalised due to the implementation of the--- <https://wiki.haskell.org/Foldable_Traversable_In_Prelude Foldable/Traversable-in-Prelude Proposal (FTP)>.------ If the operations needed are available in "GHC.List", it's--- recommended to avoid importing this module and use "GHC.List"--- instead for now.------ @since 4.8.0.0--------------------------------------------------------------------------------module GHC.OldList (module Data.OldList) where--import Data.OldList
− GHC/OverloadedLabels.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.OverloadedLabels--- Copyright   :  (c) Adam Gundry 2015-2016--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ This module defines the 'IsLabel' class used by the--- @OverloadedLabels@ extension.  See the--- <https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields/overloaded-labels wiki page>--- for more details.------ When @OverloadedLabels@ is enabled, if GHC sees an occurrence of--- the overloaded label syntax @#foo@, it is replaced with------ > fromLabel @"foo" :: alpha------ plus a wanted constraint @IsLabel "foo" alpha@.------ Note that if @RebindableSyntax@ is enabled, the desugaring of--- overloaded label syntax will make use of whatever @fromLabel@ is in--- scope.------------------------------------------------------------------------------------- Note [Overloaded labels]--- ~~~~~~~~~~~~~~~~~~~~~~~~--- An overloaded label is represented by the 'HsOverLabel' constructor--- of 'HsExpr', which stores the 'FastString' text of the label and an--- optional id for the 'fromLabel' function to use (if--- RebindableSyntax is enabled) .  The type-checker transforms it into--- a call to 'fromLabel'.  See Note [Type-checking overloaded labels]--- in GHC.Tc.Gen.Expr for more details in how type-checking works.--module GHC.OverloadedLabels-       ( IsLabel(..)-       ) where--import GHC.Base ( Symbol )--class IsLabel (x :: Symbol) a where-  fromLabel :: a
− GHC/Pack.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Pack--- Copyright   :  (c) The University of Glasgow 1997-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ This module provides a small set of low-level functions for packing--- and unpacking a chunk of bytes. Used by code emitted by the compiler--- plus the prelude libraries.------ The programmer level view of packed strings is provided by a GHC--- system library PackedString.-----------------------------------------------------------------------------------module GHC.Pack-       (-        -- (**) - emitted by compiler.--        packCString#,-        unpackCString,-        unpackCString#,-        unpackNBytes#,-        unpackFoldrCString#,  -- (**)-        unpackAppendCString#,  -- (**)-       )-        where--import GHC.Base-import GHC.List ( length )-import GHC.ST-import GHC.Ptr--data ByteArray ix              = ByteArray        ix ix ByteArray#-data MutableByteArray s ix     = MutableByteArray ix ix (MutableByteArray# s)--unpackCString :: Ptr a -> [Char]-unpackCString a@(Ptr addr)-  | a == nullPtr  = []-  | otherwise      = unpackCString# addr--packCString#         :: [Char]          -> ByteArray#-packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }--packString :: [Char] -> ByteArray Int-packString str = runST (packStringST str)--packStringST :: [Char] -> ST s (ByteArray Int)-packStringST str =-  let len = length str  in-  packNBytesST len str--packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)-packNBytesST (I# length#) str =-  {--   allocate an array that will hold the string-   (not forgetting the NUL byte at the end)-  -}- new_ps_array (length# +# 1#) >>= \ ch_array ->-   -- fill in packed string from "str"- fill_in ch_array 0# str   >>-   -- freeze the puppy:- freeze_ps_array ch_array length#- where-  fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()-  fill_in arr_in# idx [] =-   write_ps_array arr_in# idx (chr# 0#) >>-   return ()--  fill_in arr_in# idx (C# c : cs) =-   write_ps_array arr_in# idx c  >>-   fill_in arr_in# (idx +# 1#) cs---- (Very :-) ``Specialised'' versions of some CharArray things...--new_ps_array    :: Int# -> ST s (MutableByteArray s Int)-write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()-freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)--new_ps_array size = ST $ \ s ->-    case (newByteArray# size s)   of { (# s2#, barr# #) ->-    (# s2#, MutableByteArray bot bot barr# #) }-  where-    bot = errorWithoutStackTrace "new_ps_array"--write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->-    case writeCharArray# barr# n ch s#  of { s2#   ->-    (# s2#, () #) }---- same as unsafeFreezeByteArray-freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->-    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->-    (# s2#, ByteArray 0 (I# len#) frozen# #) }
− GHC/Profiling.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | @since 4.7.0.0-module GHC.Profiling ( -- * Cost Centre Profiling-                       startProfTimer-                     , stopProfTimer-                       -- * Heap Profiling-                     , startHeapProfTimer-                     , stopHeapProfTimer-                     , requestHeapCensus-                     )where--import GHC.Base---- | Stop attributing ticks to cost centres. Allocations will still be--- attributed.------ @since 4.7.0.0-foreign import ccall stopProfTimer :: IO ()---- | Start attributing ticks to cost centres. This is called by the RTS on--- startup.------ @since 4.7.0.0-foreign import ccall startProfTimer :: IO ()---- | Request a heap census on the next context switch. The census can be--- requested whether or not the heap profiling timer is running.--- Note: This won't do anything unless you also specify a profiling mode on the--- command line using the normal RTS options.------ @since 4.16.0.0-foreign import ccall requestHeapCensus :: IO ()---- | Start heap profiling. This is called normally by the RTS on start-up,--- but can be disabled using the rts flag `--no-automatic-heap-samples`--- Note: This won't do anything unless you also specify a profiling mode on the--- command line using the normal RTS options.------ @since 4.16.0.0-foreign import ccall startHeapProfTimer :: IO ()---- | Stop heap profiling.--- Note: This won't do anything unless you also specify a profiling mode on the--- command line using the normal RTS options.------ @since 4.16.0.0-foreign import ccall stopHeapProfTimer :: IO ()
− GHC/Ptr.hs 
@@ -1,178 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, RoleAnnotations #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Ptr--- Copyright   :  (c) The FFI Task Force, 2000-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  ffi@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The 'Ptr' and 'FunPtr' types and operations.-----------------------------------------------------------------------------------module GHC.Ptr (-        Ptr(..), FunPtr(..),-        nullPtr, castPtr, plusPtr, alignPtr, minusPtr,-        nullFunPtr, castFunPtr,--        -- * Unsafe functions-        castFunPtrToPtr, castPtrToFunPtr,--    ) where--import GHC.Base-import GHC.Show-import GHC.Num-import GHC.List ( length, replicate )-import Numeric          ( showHex )--#include "MachDeps.h"----------------------------------------------------------------------------- Data pointers.---- The role of Ptr's parameter is phantom, as there is no relation between--- the Haskell representation and whathever the user puts at the end of the--- pointer. And phantom is useful to implement castPtr (see #9163)---- redundant role annotation checks that this doesn't change-type role Ptr phantom-data Ptr a = Ptr Addr#-  deriving ( Eq  -- ^ @since 2.01-           , Ord -- ^ @since 2.01-           )--- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an--- array of objects, which may be marshalled to or from Haskell values--- of type @a@.------ The type @a@ will often be an instance of class--- 'Foreign.Storable.Storable' which provides the marshalling operations.--- However this is not essential, and you can provide your own operations--- to access the pointer.  For example you might write small foreign--- functions to get or set the fields of a C @struct@.---- |The constant 'nullPtr' contains a distinguished value of 'Ptr'--- that is not associated with a valid memory location.-nullPtr :: Ptr a-nullPtr = Ptr nullAddr#---- |The 'castPtr' function casts a pointer from one type to another.-castPtr :: Ptr a -> Ptr b-castPtr = coerce---- |Advances the given address by the given offset in bytes.-plusPtr :: Ptr a -> Int -> Ptr b-plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d)---- |Given an arbitrary address and an alignment constraint,--- 'alignPtr' yields the next higher address that fulfills the--- alignment constraint.  An alignment constraint @x@ is fulfilled by--- any address divisible by @x@.  This operation is idempotent.-alignPtr :: Ptr a -> Int -> Ptr a-alignPtr addr@(Ptr a) (I# i)-  = case remAddr# a i of {-      0# -> addr;-      n -> Ptr (plusAddr# a (i -# n)) }---- |Computes the offset required to get from the second to the first--- argument.  We have------ > p2 == p1 `plusPtr` (p2 `minusPtr` p1)-minusPtr :: Ptr a -> Ptr b -> Int-minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2)----------------------------------------------------------------------------- Function pointers for the default calling convention.---- 'FunPtr' has a phantom role for similar reasons to 'Ptr'.-type role FunPtr phantom-data FunPtr a = FunPtr Addr# deriving (Eq, Ord)--- ^ A value of type @'FunPtr' a@ is a pointer to a function callable--- from foreign code.  The type @a@ will normally be a /foreign type/,--- a function type with zero or more arguments where------ * the argument types are /marshallable foreign types/,---   i.e. 'Char', 'Int', 'Double', 'Float',---   'Bool', 'Data.Int.Int8', 'Data.Int.Int16', 'Data.Int.Int32',---   'Data.Int.Int64', 'Data.Word.Word8', 'Data.Word.Word16',---   'Data.Word.Word32', 'Data.Word.Word64', @'Ptr' a@, @'FunPtr' a@,---   @'Foreign.StablePtr.StablePtr' a@ or a renaming of any of these---   using @newtype@.------ * the return type is either a marshallable foreign type or has the form---   @'IO' t@ where @t@ is a marshallable foreign type or @()@.------ A value of type @'FunPtr' a@ may be a pointer to a foreign function,--- either returned by another foreign function or imported with a--- a static address import like------ > foreign import ccall "stdlib.h &free"--- >   p_free :: FunPtr (Ptr a -> IO ())------ or a pointer to a Haskell function created using a /wrapper/ stub--- declared to produce a 'FunPtr' of the correct type.  For example:------ > type Compare = Int -> Int -> Bool--- > foreign import ccall "wrapper"--- >   mkCompare :: Compare -> IO (FunPtr Compare)------ Calls to wrapper stubs like @mkCompare@ allocate storage, which--- should be released with 'Foreign.Ptr.freeHaskellFunPtr' when no--- longer required.------ To convert 'FunPtr' values to corresponding Haskell functions, one--- can define a /dynamic/ stub for the specific foreign type, e.g.------ > type IntFunction = CInt -> IO ()--- > foreign import ccall "dynamic"--- >   mkFun :: FunPtr IntFunction -> IntFunction---- |The constant 'nullFunPtr' contains a--- distinguished value of 'FunPtr' that is not--- associated with a valid memory location.-nullFunPtr :: FunPtr a-nullFunPtr = FunPtr nullAddr#---- |Casts a 'FunPtr' to a 'FunPtr' of a different type.-castFunPtr :: FunPtr a -> FunPtr b-castFunPtr = coerce---- |Casts a 'FunPtr' to a 'Ptr'.------ /Note:/ this is valid only on architectures where data and function--- pointers range over the same set of addresses, and should only be used--- for bindings to external libraries whose interface already relies on--- this assumption.-castFunPtrToPtr :: FunPtr a -> Ptr b-castFunPtrToPtr (FunPtr addr) = Ptr addr---- |Casts a 'Ptr' to a 'FunPtr'.------ /Note:/ this is valid only on architectures where data and function--- pointers range over the same set of addresses, and should only be used--- for bindings to external libraries whose interface already relies on--- this assumption.-castPtrToFunPtr :: Ptr a -> FunPtr b-castPtrToFunPtr (Ptr addr) = FunPtr addr----------------------------------------------------------------------------- Show instances for Ptr and FunPtr---- | @since 2.01-instance Show (Ptr a) where-   showsPrec _ (Ptr a) rs = pad_out (showHex (integerFromWord#(int2Word#(addr2Int# a))) "")-     where-        -- want 0s prefixed to pad it out to a fixed length.-       pad_out ls =-          '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls ++ rs---- | @since 2.01-instance Show (FunPtr a) where-   showsPrec p = showsPrec p . castFunPtrToPtr
− GHC/RTS/Flags.hsc 
@@ -1,631 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Accessors to GHC RTS flags.--- Descriptions of flags can be seen in--- <https://www.haskell.org/ghc/docs/latest/html/users_guide/runtime_control.html GHC User's Guide>,--- or by running RTS help message using @+RTS --help@.------ @since 4.8.0.0----module GHC.RTS.Flags-  ( RtsTime-  , RTSFlags (..)-  , GiveGCStats (..)-  , GCFlags (..)-  , ConcFlags (..)-  , MiscFlags (..)-  , DebugFlags (..)-  , DoCostCentres (..)-  , CCFlags (..)-  , DoHeapProfile (..)-  , ProfFlags (..)-  , DoTrace (..)-  , TraceFlags (..)-  , TickyFlags (..)-  , ParFlags (..)-  , IoSubSystem (..)-  , getRTSFlags-  , getGCFlags-  , getConcFlags-  , getMiscFlags-  , getIoManagerFlag-  , getDebugFlags-  , getCCFlags-  , getProfFlags-  , getTraceFlags-  , getTickyFlags-  , getParFlags-  ) where--#include "Rts.h"-#include "rts/Flags.h"--import Data.Functor ((<$>))--import Foreign-import Foreign.C--import GHC.Base-import GHC.Enum-import GHC.Generics (Generic)-import GHC.IO-import GHC.Real-import GHC.Show---- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@------ @since 4.8.2.0-type RtsTime = Word64---- | Should we produce a summary of the garbage collector statistics after the--- program has exited?------ @since 4.8.2.0-data GiveGCStats-    = NoGCStats-    | CollectGCStats-    | OneLineGCStats-    | SummaryGCStats-    | VerboseGCStats-    deriving ( Show -- ^ @since 4.8.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | @since 4.8.0.0-instance Enum GiveGCStats where-    fromEnum NoGCStats      = #{const NO_GC_STATS}-    fromEnum CollectGCStats = #{const COLLECT_GC_STATS}-    fromEnum OneLineGCStats = #{const ONELINE_GC_STATS}-    fromEnum SummaryGCStats = #{const SUMMARY_GC_STATS}-    fromEnum VerboseGCStats = #{const VERBOSE_GC_STATS}--    toEnum #{const NO_GC_STATS}      = NoGCStats-    toEnum #{const COLLECT_GC_STATS} = CollectGCStats-    toEnum #{const ONELINE_GC_STATS} = OneLineGCStats-    toEnum #{const SUMMARY_GC_STATS} = SummaryGCStats-    toEnum #{const VERBOSE_GC_STATS} = VerboseGCStats-    toEnum e = errorWithoutStackTrace ("invalid enum for GiveGCStats: " ++ show e)---- | The I/O SubSystem to use in the program.------ @since 4.9.0.0-data IoSubSystem-  = IoPOSIX   -- ^ Use a POSIX I/O Sub-System-  | IoNative  -- ^ Use platform native Sub-System. For unix OSes this is the-              --   same as IoPOSIX, but on Windows this means use the Windows-              --   native APIs for I/O, including IOCP and RIO.-  deriving (Eq, Show)---- | @since 4.9.0.0-instance Enum IoSubSystem where-    fromEnum IoPOSIX  = #{const IO_MNGR_POSIX}-    fromEnum IoNative = #{const IO_MNGR_NATIVE}--    toEnum #{const IO_MNGR_POSIX}  = IoPOSIX-    toEnum #{const IO_MNGR_NATIVE} = IoNative-    toEnum e = errorWithoutStackTrace ("invalid enum for IoSubSystem: " ++ show e)---- | @since 4.9.0.0-instance Storable IoSubSystem where-    sizeOf = sizeOf . fromEnum-    alignment = sizeOf . fromEnum-    peek ptr = fmap toEnum $ peek (castPtr ptr)-    poke ptr v = poke (castPtr ptr) (fromEnum v)---- | Parameters of the garbage collector.------ @since 4.8.0.0-data GCFlags = GCFlags-    { statsFile             :: Maybe FilePath-    , giveStats             :: GiveGCStats-    , maxStkSize            :: Word32-    , initialStkSize        :: Word32-    , stkChunkSize          :: Word32-    , stkChunkBufferSize    :: Word32-    , maxHeapSize           :: Word32-    , minAllocAreaSize      :: Word32-    , largeAllocLim         :: Word32-    , nurseryChunkSize      :: Word32-    , minOldGenSize         :: Word32-    , heapSizeSuggestion    :: Word32-    , heapSizeSuggestionAuto :: Bool-    , oldGenFactor          :: Double-    , returnDecayFactor     :: Double-    , pcFreeHeap            :: Double-    , generations           :: Word32-    , squeezeUpdFrames      :: Bool-    , compact               :: Bool -- ^ True <=> "compact all the time"-    , compactThreshold      :: Double-    , sweep                 :: Bool-      -- ^ use "mostly mark-sweep" instead of copying for the oldest generation-    , ringBell              :: Bool-    , idleGCDelayTime       :: RtsTime-    , doIdleGC              :: Bool-    , heapBase              :: Word -- ^ address to ask the OS for memory-    , allocLimitGrace       :: Word-    , numa                  :: Bool-    , numaMask              :: Word-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Parameters concerning context switching------ @since 4.8.0.0-data ConcFlags = ConcFlags-    { ctxtSwitchTime  :: RtsTime-    , ctxtSwitchTicks :: Int-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Miscellaneous parameters------ @since 4.8.0.0-data MiscFlags = MiscFlags-    { tickInterval          :: RtsTime-    , installSignalHandlers :: Bool-    , installSEHHandlers    :: Bool-    , generateCrashDumpFile :: Bool-    , generateStackTrace    :: Bool-    , machineReadable       :: Bool-    , disableDelayedOsMemoryReturn :: Bool-    , internalCounters      :: Bool-    , linkerAlwaysPic       :: Bool-    , linkerMemBase         :: Word-      -- ^ address to ask the OS for memory for the linker, 0 ==> off-    , ioManager             :: IoSubSystem-    , numIoWorkerThreads    :: Word32-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Flags to control debugging output & extra checking in various--- subsystems.------ @since 4.8.0.0-data DebugFlags = DebugFlags-    { scheduler      :: Bool -- ^ @s@-    , interpreter    :: Bool -- ^ @i@-    , weak           :: Bool -- ^ @w@-    , gccafs         :: Bool -- ^ @G@-    , gc             :: Bool -- ^ @g@-    , nonmoving_gc   :: Bool -- ^ @n@-    , block_alloc    :: Bool -- ^ @b@-    , sanity         :: Bool -- ^ @S@-    , stable         :: Bool -- ^ @t@-    , prof           :: Bool -- ^ @p@-    , linker         :: Bool -- ^ @l@ the object linker-    , apply          :: Bool -- ^ @a@-    , stm            :: Bool -- ^ @m@-    , squeeze        :: Bool -- ^ @z@ stack squeezing & lazy blackholing-    , hpc            :: Bool -- ^ @c@ coverage-    , sparks         :: Bool -- ^ @r@-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Should the RTS produce a cost-center summary?------ @since 4.8.2.0-data DoCostCentres-    = CostCentresNone-    | CostCentresSummary-    | CostCentresVerbose-    | CostCentresAll-    | CostCentresJSON-    deriving ( Show -- ^ @since 4.8.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | @since 4.8.0.0-instance Enum DoCostCentres where-    fromEnum CostCentresNone    = #{const COST_CENTRES_NONE}-    fromEnum CostCentresSummary = #{const COST_CENTRES_SUMMARY}-    fromEnum CostCentresVerbose = #{const COST_CENTRES_VERBOSE}-    fromEnum CostCentresAll     = #{const COST_CENTRES_ALL}-    fromEnum CostCentresJSON    = #{const COST_CENTRES_JSON}--    toEnum #{const COST_CENTRES_NONE}    = CostCentresNone-    toEnum #{const COST_CENTRES_SUMMARY} = CostCentresSummary-    toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose-    toEnum #{const COST_CENTRES_ALL}     = CostCentresAll-    toEnum #{const COST_CENTRES_JSON}    = CostCentresJSON-    toEnum e = errorWithoutStackTrace ("invalid enum for DoCostCentres: " ++ show e)---- | Parameters pertaining to the cost-center profiler.------ @since 4.8.0.0-data CCFlags = CCFlags-    { doCostCentres :: DoCostCentres-    , profilerTicks :: Int-    , msecsPerTick  :: Int-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | What sort of heap profile are we collecting?------ @since 4.8.2.0-data DoHeapProfile-    = NoHeapProfiling-    | HeapByCCS-    | HeapByMod-    | HeapByDescr-    | HeapByType-    | HeapByRetainer-    | HeapByLDV-    | HeapByClosureType-    | HeapByInfoTable-    deriving ( Show -- ^ @since 4.8.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | @since 4.8.0.0-instance Enum DoHeapProfile where-    fromEnum NoHeapProfiling   = #{const NO_HEAP_PROFILING}-    fromEnum HeapByCCS         = #{const HEAP_BY_CCS}-    fromEnum HeapByMod         = #{const HEAP_BY_MOD}-    fromEnum HeapByDescr       = #{const HEAP_BY_DESCR}-    fromEnum HeapByType        = #{const HEAP_BY_TYPE}-    fromEnum HeapByRetainer    = #{const HEAP_BY_RETAINER}-    fromEnum HeapByLDV         = #{const HEAP_BY_LDV}-    fromEnum HeapByClosureType = #{const HEAP_BY_CLOSURE_TYPE}-    fromEnum HeapByInfoTable   = #{const HEAP_BY_INFO_TABLE}--    toEnum #{const NO_HEAP_PROFILING}    = NoHeapProfiling-    toEnum #{const HEAP_BY_CCS}          = HeapByCCS-    toEnum #{const HEAP_BY_MOD}          = HeapByMod-    toEnum #{const HEAP_BY_DESCR}        = HeapByDescr-    toEnum #{const HEAP_BY_TYPE}         = HeapByType-    toEnum #{const HEAP_BY_RETAINER}     = HeapByRetainer-    toEnum #{const HEAP_BY_LDV}          = HeapByLDV-    toEnum #{const HEAP_BY_CLOSURE_TYPE} = HeapByClosureType-    toEnum #{const HEAP_BY_INFO_TABLE}   = HeapByInfoTable-    toEnum e = errorWithoutStackTrace ("invalid enum for DoHeapProfile: " ++ show e)---- | Parameters of the cost-center profiler------ @since 4.8.0.0-data ProfFlags = ProfFlags-    { doHeapProfile            :: DoHeapProfile-    , heapProfileInterval      :: RtsTime -- ^ time between samples-    , heapProfileIntervalTicks :: Word    -- ^ ticks between samples (derived)-    , startHeapProfileAtStartup :: Bool-    , showCCSOnException       :: Bool-    , maxRetainerSetSize       :: Word-    , ccsLength                :: Word-    , modSelector              :: Maybe String-    , descrSelector            :: Maybe String-    , typeSelector             :: Maybe String-    , ccSelector               :: Maybe String-    , ccsSelector              :: Maybe String-    , retainerSelector         :: Maybe String-    , bioSelector              :: Maybe String-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Is event tracing enabled?------ @since 4.8.2.0-data DoTrace-    = TraceNone      -- ^ no tracing-    | TraceEventLog  -- ^ send tracing events to the event log-    | TraceStderr    -- ^ send tracing events to @stderr@-    deriving ( Show -- ^ @since 4.8.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | @since 4.8.0.0-instance Enum DoTrace where-    fromEnum TraceNone     = #{const TRACE_NONE}-    fromEnum TraceEventLog = #{const TRACE_EVENTLOG}-    fromEnum TraceStderr   = #{const TRACE_STDERR}--    toEnum #{const TRACE_NONE}     = TraceNone-    toEnum #{const TRACE_EVENTLOG} = TraceEventLog-    toEnum #{const TRACE_STDERR}   = TraceStderr-    toEnum e = errorWithoutStackTrace ("invalid enum for DoTrace: " ++ show e)---- | Parameters pertaining to event tracing------ @since 4.8.0.0-data TraceFlags = TraceFlags-    { tracing        :: DoTrace-    , timestamp      :: Bool -- ^ show timestamp in stderr output-    , traceScheduler :: Bool -- ^ trace scheduler events-    , traceGc        :: Bool -- ^ trace GC events-    , traceNonmovingGc-                     :: Bool -- ^ trace nonmoving GC heap census samples-    , sparksSampled  :: Bool -- ^ trace spark events by a sampled method-    , sparksFull     :: Bool -- ^ trace spark events 100% accurately-    , user           :: Bool -- ^ trace user events (emitted from Haskell code)-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Parameters pertaining to ticky-ticky profiler------ @since 4.8.0.0-data TickyFlags = TickyFlags-    { showTickyStats :: Bool-    , tickyFile      :: Maybe FilePath-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )---- | Parameters pertaining to parallelism------ @since 4.8.0.0-data ParFlags = ParFlags-    { nCapabilities :: Word32-    , migrate :: Bool-    , maxLocalSparks :: Word32-    , parGcEnabled :: Bool-    , parGcGen :: Word32-    , parGcLoadBalancingEnabled :: Bool-    , parGcLoadBalancingGen :: Word32-    , parGcNoSyncWithIdle :: Word32-    , parGcThreads :: Word32-    , setAffinity :: Bool-    }-    deriving ( Show -- ^ @since 4.8.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | Parameters of the runtime system------ @since 4.8.0.0-data RTSFlags = RTSFlags-    { gcFlags         :: GCFlags-    , concurrentFlags :: ConcFlags-    , miscFlags       :: MiscFlags-    , debugFlags      :: DebugFlags-    , costCentreFlags :: CCFlags-    , profilingFlags  :: ProfFlags-    , traceFlags      :: TraceFlags-    , tickyFlags      :: TickyFlags-    , parFlags        :: ParFlags-    } deriving ( Show -- ^ @since 4.8.0.0-               , Generic -- ^ @since 4.15.0.0-               )--foreign import ccall "&RtsFlags" rtsFlagsPtr :: Ptr RTSFlags--getRTSFlags :: IO RTSFlags-getRTSFlags =-  RTSFlags <$> getGCFlags-           <*> getConcFlags-           <*> getMiscFlags-           <*> getDebugFlags-           <*> getCCFlags-           <*> getProfFlags-           <*> getTraceFlags-           <*> getTickyFlags-           <*> getParFlags--peekFilePath :: Ptr () -> IO (Maybe FilePath)-peekFilePath ptr-  | ptr == nullPtr = return Nothing-  | otherwise      = return (Just "<filepath>")---- | Read a NUL terminated string. Return Nothing in case of a NULL pointer.-peekCStringOpt :: Ptr CChar -> IO (Maybe String)-peekCStringOpt ptr-  | ptr == nullPtr = return Nothing-  | otherwise      = Just <$> peekCString ptr--getGCFlags :: IO GCFlags-getGCFlags = do-  let ptr = (#ptr RTS_FLAGS, GcFlags) rtsFlagsPtr-  GCFlags <$> (peekFilePath =<< #{peek GC_FLAGS, statsFile} ptr)-          <*> (toEnum . fromIntegral <$>-                (#{peek GC_FLAGS, giveStats} ptr :: IO Word32))-          <*> #{peek GC_FLAGS, maxStkSize} ptr-          <*> #{peek GC_FLAGS, initialStkSize} ptr-          <*> #{peek GC_FLAGS, stkChunkSize} ptr-          <*> #{peek GC_FLAGS, stkChunkBufferSize} ptr-          <*> #{peek GC_FLAGS, maxHeapSize} ptr-          <*> #{peek GC_FLAGS, minAllocAreaSize} ptr-          <*> #{peek GC_FLAGS, largeAllocLim} ptr-          <*> #{peek GC_FLAGS, nurseryChunkSize} ptr-          <*> #{peek GC_FLAGS, minOldGenSize} ptr-          <*> #{peek GC_FLAGS, heapSizeSuggestion} ptr-          <*> (toBool <$>-                (#{peek GC_FLAGS, heapSizeSuggestionAuto} ptr :: IO CBool))-          <*> #{peek GC_FLAGS, oldGenFactor} ptr-          <*> #{peek GC_FLAGS, returnDecayFactor} ptr-          <*> #{peek GC_FLAGS, pcFreeHeap} ptr-          <*> #{peek GC_FLAGS, generations} ptr-          <*> (toBool <$>-                (#{peek GC_FLAGS, squeezeUpdFrames} ptr :: IO CBool))-          <*> (toBool <$>-                (#{peek GC_FLAGS, compact} ptr :: IO CBool))-          <*> #{peek GC_FLAGS, compactThreshold} ptr-          <*> (toBool <$>-                (#{peek GC_FLAGS, sweep} ptr :: IO CBool))-          <*> (toBool <$>-                (#{peek GC_FLAGS, ringBell} ptr :: IO CBool))-          <*> #{peek GC_FLAGS, idleGCDelayTime} ptr-          <*> (toBool <$>-                (#{peek GC_FLAGS, doIdleGC} ptr :: IO CBool))-          <*> #{peek GC_FLAGS, heapBase} ptr-          <*> #{peek GC_FLAGS, allocLimitGrace} ptr-          <*> (toBool <$>-                (#{peek GC_FLAGS, numa} ptr :: IO CBool))-          <*> #{peek GC_FLAGS, numaMask} ptr--getParFlags :: IO ParFlags-getParFlags = do-  let ptr = (#ptr RTS_FLAGS, ParFlags) rtsFlagsPtr-  ParFlags-    <$> #{peek PAR_FLAGS, nCapabilities} ptr-    <*> (toBool <$>-          (#{peek PAR_FLAGS, migrate} ptr :: IO CBool))-    <*> #{peek PAR_FLAGS, maxLocalSparks} ptr-    <*> (toBool <$>-          (#{peek PAR_FLAGS, parGcEnabled} ptr :: IO CBool))-    <*> #{peek PAR_FLAGS, parGcGen} ptr-    <*> (toBool <$>-          (#{peek PAR_FLAGS, parGcLoadBalancingEnabled} ptr :: IO CBool))-    <*> #{peek PAR_FLAGS, parGcLoadBalancingGen} ptr-    <*> #{peek PAR_FLAGS, parGcNoSyncWithIdle} ptr-    <*> #{peek PAR_FLAGS, parGcThreads} ptr-    <*> (toBool <$>-          (#{peek PAR_FLAGS, setAffinity} ptr :: IO CBool))--getConcFlags :: IO ConcFlags-getConcFlags = do-  let ptr = (#ptr RTS_FLAGS, ConcFlags) rtsFlagsPtr-  ConcFlags <$> #{peek CONCURRENT_FLAGS, ctxtSwitchTime} ptr-            <*> #{peek CONCURRENT_FLAGS, ctxtSwitchTicks} ptr--{-# INLINEABLE getMiscFlags #-}-getMiscFlags :: IO MiscFlags-getMiscFlags = do-  let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr-  MiscFlags <$> #{peek MISC_FLAGS, tickInterval} ptr-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, install_signal_handlers} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, install_seh_handlers} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, generate_dump_file} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, generate_stack_trace} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, machineReadable} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, disableDelayedOsMemoryReturn} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, internalCounters} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek MISC_FLAGS, linkerAlwaysPic} ptr :: IO CBool))-            <*> #{peek MISC_FLAGS, linkerMemBase} ptr-            <*> (toEnum . fromIntegral-                 <$> (#{peek MISC_FLAGS, ioManager} ptr :: IO Word32))-            <*> (fromIntegral-                 <$> (#{peek MISC_FLAGS, numIoWorkerThreads} ptr :: IO Word32))--{- Note [The need for getIoManagerFlag]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--   GHC supports both the new WINIO manager-   as well as the old MIO one. In order to-   decide which code path to take we often-   have to inspect what the user selected at-   RTS startup.--   We could use getMiscFlags but then we end up with core containing-   reads for all MiscFlags. These won't be eliminated at the core level-   even if it's obvious we will only look at the ioManager part of the-   ADT.--   We could add a INLINE pragma, but that just means whatever we inline-   into is likely to be inlined. So rather than adding a dozen pragmas-   we expose a lean way to query this particular flag. It's not satisfying-   but it works well enough and allows these checks to be inlined nicely.---}--{-# INLINE getIoManagerFlag #-}--- | Needed to optimize support for different IO Managers on Windows.--- See Note [The need for getIoManagerFlag]-getIoManagerFlag :: IO IoSubSystem-getIoManagerFlag = do-      let ptr = (#ptr RTS_FLAGS, MiscFlags) rtsFlagsPtr-      mgrFlag <- (#{peek MISC_FLAGS, ioManager} ptr :: IO Word32)-      return $ (toEnum . fromIntegral) mgrFlag--getDebugFlags :: IO DebugFlags-getDebugFlags = do-  let ptr = (#ptr RTS_FLAGS, DebugFlags) rtsFlagsPtr-  DebugFlags <$> (toBool <$>-                   (#{peek DEBUG_FLAGS, scheduler} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, interpreter} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, weak} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, gccafs} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, gc} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, nonmoving_gc} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, block_alloc} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, sanity} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, stable} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, prof} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, linker} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, apply} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, stm} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, squeeze} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, hpc} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek DEBUG_FLAGS, sparks} ptr :: IO CBool))--getCCFlags :: IO CCFlags-getCCFlags = do-  let ptr = (#ptr RTS_FLAGS, GcFlags) rtsFlagsPtr-  CCFlags <$> (toEnum . fromIntegral-                <$> (#{peek COST_CENTRE_FLAGS, doCostCentres} ptr :: IO Word32))-          <*> #{peek COST_CENTRE_FLAGS, profilerTicks} ptr-          <*> #{peek COST_CENTRE_FLAGS, msecsPerTick} ptr--getProfFlags :: IO ProfFlags-getProfFlags = do-  let ptr = (#ptr RTS_FLAGS, ProfFlags) rtsFlagsPtr-  ProfFlags <$> (toEnum <$> #{peek PROFILING_FLAGS, doHeapProfile} ptr)-            <*> #{peek PROFILING_FLAGS, heapProfileInterval} ptr-            <*> #{peek PROFILING_FLAGS, heapProfileIntervalTicks} ptr-            <*> (toBool <$>-                  (#{peek PROFILING_FLAGS, startHeapProfileAtStartup} ptr :: IO CBool))-            <*> (toBool <$>-                  (#{peek PROFILING_FLAGS, showCCSOnException} ptr :: IO CBool))-            <*> #{peek PROFILING_FLAGS, maxRetainerSetSize} ptr-            <*> #{peek PROFILING_FLAGS, ccsLength} ptr-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, modSelector} ptr)-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, descrSelector} ptr)-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, typeSelector} ptr)-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, ccSelector} ptr)-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, ccsSelector} ptr)-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, retainerSelector} ptr)-            <*> (peekCStringOpt =<< #{peek PROFILING_FLAGS, bioSelector} ptr)--getTraceFlags :: IO TraceFlags-getTraceFlags = do-  let ptr = (#ptr RTS_FLAGS, TraceFlags) rtsFlagsPtr-  TraceFlags <$> (toEnum . fromIntegral-                   <$> (#{peek TRACE_FLAGS, tracing} ptr :: IO CInt))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, timestamp} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, scheduler} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, gc} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, nonmoving_gc} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, sparks_sampled} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, sparks_full} ptr :: IO CBool))-             <*> (toBool <$>-                   (#{peek TRACE_FLAGS, user} ptr :: IO CBool))--getTickyFlags :: IO TickyFlags-getTickyFlags = do-  let ptr = (#ptr RTS_FLAGS, TickyFlags) rtsFlagsPtr-  TickyFlags <$> (toBool <$>-                   (#{peek TICKY_FLAGS, showTickyStats} ptr :: IO CBool))-             <*> (peekFilePath =<< #{peek TICKY_FLAGS, tickyFile} ptr)
− GHC/Read.hs 
@@ -1,829 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Read--- 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)------ The 'Read' class and instances for basic data types.-----------------------------------------------------------------------------------module GHC.Read-  ( Read(..)   -- class--  -- ReadS type-  , ReadS--  -- H2010 compatibility-  , lex-  , lexLitChar-  , readLitChar-  , lexDigits--  -- defining readers-  , lexP, expectP-  , paren-  , parens-  , list-  , choose-  , readListDefault, readListPrecDefault-  , readNumber-  , readField-  , readFieldHash-  , readSymField--  -- Temporary-  , readParen-  )- where--#include "MachDeps.h"--import qualified Text.ParserCombinators.ReadP as P--import Text.ParserCombinators.ReadP-  ( ReadS-  , readP_to_S-  )--import qualified Text.Read.Lex as L--- Lex exports 'lex', which is also defined here,--- hence the qualified import.--- We can't import *anything* unqualified, because that--- confuses Haddock.--import Text.ParserCombinators.ReadPrec--import Data.Maybe--import GHC.Unicode-import GHC.Num-import GHC.Real-import GHC.Float-import GHC.Show-import GHC.Base-import GHC.Arr-import GHC.Word-import GHC.List (filter)-import GHC.Tuple (Solo (..))----- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with--- parentheses.------ @'readParen' 'False' p@ parses what @p@ parses, but optionally--- surrounded with parentheses.-readParen       :: Bool -> ReadS a -> ReadS a--- A Haskell 2010 function-readParen b g   =  if b then mandatory else optional-                   where optional r  = g r ++ mandatory r-                         mandatory r = do-                                ("(",s) <- lex r-                                (x,t)   <- optional s-                                (")",u) <- lex t-                                return (x,u)---- | Parsing of 'String's, producing values.------ Derived instances of 'Read' make the following assumptions, which--- derived instances of 'Text.Show.Show' obey:------ * If the constructor is defined to be an infix operator, then the---   derived 'Read' instance will parse only infix applications of---   the constructor (not the prefix form).------ * Associativity is not used to reduce the occurrence of parentheses,---   although precedence may be.------ * If the constructor is defined using record syntax, the derived 'Read'---   will parse only the record-syntax form, and furthermore, the fields---   must be given in the same order as the original declaration.------ * The derived 'Read' instance allows arbitrary Haskell whitespace---   between tokens of the input string.  Extra parentheses are also---   allowed.------ For example, given the declarations------ > infixr 5 :^:--- > data Tree a =  Leaf a  |  Tree a :^: Tree a------ the derived instance of 'Read' in Haskell 2010 is equivalent to------ > instance (Read a) => Read (Tree a) where--- >--- >         readsPrec d r =  readParen (d > app_prec)--- >                          (\r -> [(Leaf m,t) |--- >                                  ("Leaf",s) <- lex r,--- >                                  (m,t) <- readsPrec (app_prec+1) s]) r--- >--- >                       ++ readParen (d > up_prec)--- >                          (\r -> [(u:^:v,w) |--- >                                  (u,s) <- readsPrec (up_prec+1) r,--- >                                  (":^:",t) <- lex s,--- >                                  (v,w) <- readsPrec (up_prec+1) t]) r--- >--- >           where app_prec = 10--- >                 up_prec = 5------ Note that right-associativity of @:^:@ is unused.------ The derived instance in GHC is equivalent to------ > instance (Read a) => Read (Tree a) where--- >--- >         readPrec = parens $ (prec app_prec $ do--- >                                  Ident "Leaf" <- lexP--- >                                  m <- step readPrec--- >                                  return (Leaf m))--- >--- >                      +++ (prec up_prec $ do--- >                                  u <- step readPrec--- >                                  Symbol ":^:" <- lexP--- >                                  v <- step readPrec--- >                                  return (u :^: v))--- >--- >           where app_prec = 10--- >                 up_prec = 5--- >--- >         readListPrec = readListPrecDefault------ Why do both 'readsPrec' and 'readPrec' exist, and why does GHC opt to--- implement 'readPrec' in derived 'Read' instances instead of 'readsPrec'?--- The reason is that 'readsPrec' is based on the 'ReadS' type, and although--- 'ReadS' is mentioned in the Haskell 2010 Report, it is not a very efficient--- parser data structure.------ 'readPrec', on the other hand, is based on a much more efficient 'ReadPrec'--- datatype (a.k.a \"new-style parsers\"), but its definition relies on the use--- of the @RankNTypes@ language extension. Therefore, 'readPrec' (and its--- cousin, 'readListPrec') are marked as GHC-only. Nevertheless, it is--- recommended to use 'readPrec' instead of 'readsPrec' whenever possible--- for the efficiency improvements it brings.------ As mentioned above, derived 'Read' instances in GHC will implement--- 'readPrec' instead of 'readsPrec'. The default implementations of--- 'readsPrec' (and its cousin, 'readList') will simply use 'readPrec' under--- the hood. If you are writing a 'Read' instance by hand, it is recommended--- to write it like so:------ @--- instance 'Read' T where---   'readPrec'     = ...---   'readListPrec' = 'readListPrecDefault'--- @--class Read a where-  {-# MINIMAL readsPrec | readPrec #-}--  -- | attempts to parse a value from the front of the string, returning-  -- a list of (parsed value, remaining string) pairs.  If there is no-  -- successful parse, the returned list is empty.-  ---  -- Derived instances of 'Read' and 'Text.Show.Show' satisfy the following:-  ---  -- * @(x,\"\")@ is an element of-  --   @('readsPrec' d ('Text.Show.showsPrec' d x \"\"))@.-  ---  -- That is, 'readsPrec' parses the string produced by-  -- 'Text.Show.showsPrec', and delivers the value that-  -- 'Text.Show.showsPrec' started with.--  readsPrec    :: Int   -- ^ the operator precedence of the enclosing-                        -- context (a number from @0@ to @11@).-                        -- Function application has precedence @10@.-                -> ReadS a--  -- | The method 'readList' is provided to allow the programmer to-  -- give a specialised way of parsing lists of values.-  -- For example, this is used by the predefined 'Read' instance of-  -- the 'Char' type, where values of type 'String' should be are-  -- expected to use double quotes, rather than square brackets.-  readList     :: ReadS [a]--  -- | Proposed replacement for 'readsPrec' using new-style parsers (GHC only).-  readPrec     :: ReadPrec a--  -- | Proposed replacement for 'readList' using new-style parsers (GHC only).-  -- The default definition uses 'readList'.  Instances that define 'readPrec'-  -- should also define 'readListPrec' as 'readListPrecDefault'.-  readListPrec :: ReadPrec [a]--  -- default definitions-  readsPrec    = readPrec_to_S readPrec-  readList     = readPrec_to_S (list readPrec) 0-  readPrec     = readS_to_Prec readsPrec-  readListPrec = readS_to_Prec (\_ -> readList)--readListDefault :: Read a => ReadS [a]--- ^ A possible replacement definition for the 'readList' method (GHC only).---   This is only needed for GHC, and even then only for 'Read' instances---   where 'readListPrec' isn't defined as 'readListPrecDefault'.-readListDefault = readPrec_to_S readListPrec 0--readListPrecDefault :: Read a => ReadPrec [a]--- ^ A possible replacement definition for the 'readListPrec' method,---   defined using 'readPrec' (GHC only).-readListPrecDefault = list readPrec----------------------------------------------------------------------------- H2010 compatibility---- | The 'lex' function reads a single lexeme from the input, discarding--- initial white space, and returning the characters that constitute the--- lexeme.  If the input string contains only white space, 'lex' returns a--- single successful \`lexeme\' consisting of the empty string.  (Thus--- @'lex' \"\" = [(\"\",\"\")]@.)  If there is no legal lexeme at the--- beginning of the input string, 'lex' fails (i.e. returns @[]@).------ This lexer is not completely faithful to the Haskell lexical syntax--- in the following respects:------ * Qualified names are not handled properly------ * Octal and hexadecimal numerics are not recognized as a single token------ * Comments are not treated properly-lex :: ReadS String             -- As defined by H2010-lex s  = readP_to_S L.hsLex s---- | Read a string representation of a character, using Haskell--- source-language escape conventions.  For example:------ > lexLitChar  "\\nHello"  =  [("\\n", "Hello")]----lexLitChar :: ReadS String      -- As defined by H2010-lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;-                              let s' = removeNulls s in-                              return s' })-    where-    -- remove nulls from end of the character if they exist-    removeNulls [] = []-    removeNulls ('\\':'&':xs) = removeNulls xs-    removeNulls (first:rest) = first : removeNulls rest-        -- There was a skipSpaces before the P.gather L.lexChar,-        -- but that seems inconsistent with readLitChar---- | Read a string representation of a character, using Haskell--- source-language escape conventions, and convert it to the character--- that it encodes.  For example:------ > readLitChar "\\nHello"  =  [('\n', "Hello")]----readLitChar :: ReadS Char       -- As defined by H2010-readLitChar = readP_to_S L.lexChar---- | Reads a non-empty string of decimal digits.-lexDigits :: ReadS String-lexDigits = readP_to_S (P.munch1 isDigit)----------------------------------------------------------------------------- utility parsers--lexP :: ReadPrec L.Lexeme--- ^ Parse a single lexeme-lexP = lift L.lex--expectP :: L.Lexeme -> ReadPrec ()-expectP lexeme = lift (L.expect lexeme)--expectCharP :: Char -> ReadPrec a -> ReadPrec a-expectCharP c a = do-  q <- get-  if q == c-    then a-    else pfail-{-# INLINE expectCharP #-}--skipSpacesThenP :: ReadPrec a -> ReadPrec a-skipSpacesThenP m =-  do s <- look-     skip s- where-   skip (c:s) | isSpace c = get *> skip s-   skip _ = m--paren :: ReadPrec a -> ReadPrec a--- ^ @(paren p)@ parses \"(P0)\"---      where @p@ parses \"P0\" in precedence context zero-paren p = skipSpacesThenP (paren' p)--paren' :: ReadPrec a -> ReadPrec a-paren' p = expectCharP '(' $ reset p >>= \x ->-              skipSpacesThenP (expectCharP ')' (pure x))--parens :: ReadPrec a -> ReadPrec a--- ^ @(parens p)@ parses \"P\", \"(P0)\", \"((P0))\", etc,---      where @p@ parses \"P\"  in the current precedence context---          and parses \"P0\" in precedence context zero-parens p = optional-  where-    optional = skipSpacesThenP (p +++ mandatory)-    mandatory = paren' optional--list :: ReadPrec a -> ReadPrec [a]--- ^ @(list p)@ parses a list of things parsed by @p@,--- using the usual square-bracket syntax.-list readx =-  parens-  ( do expectP (L.Punc "[")-       (listRest False +++ listNext)-  )- where-  listRest started =-    do L.Punc c <- lexP-       case c of-         "]"           -> return []-         "," | started -> listNext-         _             -> pfail--  listNext =-    do x  <- reset readx-       xs <- listRest True-       return (x:xs)--choose :: [(String, ReadPrec a)] -> ReadPrec a--- ^ Parse the specified lexeme and continue as specified.--- Esp useful for nullary constructors; e.g.---    @choose [(\"A\", return A), (\"B\", return B)]@--- We match both Ident and Symbol because the constructor--- might be an operator eg @(:~:)@-choose sps = foldr ((+++) . try_one) pfail sps-           where-             try_one (s,p) = do { token <- lexP ;-                                  case token of-                                    L.Ident s'  | s==s' -> p-                                    L.Symbol s' | s==s' -> p-                                    _other              -> pfail }---- See Note [Why readField]---- | 'Read' parser for a record field, of the form @fieldName=value@. The--- @fieldName@ must be an alphanumeric identifier; for symbols (operator-style)--- field names, e.g. @(#)@, use 'readSymField'). The second argument is a--- parser for the field value.-readField :: String -> ReadPrec a -> ReadPrec a-readField fieldName readVal = do-        expectP (L.Ident fieldName)-        expectP (L.Punc "=")-        readVal-{-# NOINLINE readField #-}---- See Note [Why readField]---- | 'Read' parser for a record field, of the form @fieldName#=value@. That is,--- an alphanumeric identifier @fieldName@ followed by the symbol @#@. The--- second argument is a parser for the field value.------ Note that 'readField' does not suffice for this purpose due to--- <https://gitlab.haskell.org/ghc/ghc/issues/5041 #5041>.-readFieldHash :: String -> ReadPrec a -> ReadPrec a-readFieldHash fieldName readVal = do-        expectP (L.Ident fieldName)-        expectP (L.Symbol "#")-        expectP (L.Punc "=")-        readVal-{-# NOINLINE readFieldHash #-}---- See Note [Why readField]---- | 'Read' parser for a symbol record field, of the form @(###)=value@ (where--- @###@ is the field name). The field name must be a symbol (operator-style),--- e.g. @(#)@. For regular (alphanumeric) field names, use 'readField'. The--- second argument is a parser for the field value.-readSymField :: String -> ReadPrec a -> ReadPrec a-readSymField fieldName readVal = do-        expectP (L.Punc "(")-        expectP (L.Symbol fieldName)-        expectP (L.Punc ")")-        expectP (L.Punc "=")-        readVal-{-# NOINLINE readSymField #-}----- Note [Why readField]------ Previously, the code for automatically deriving Read instance (in--- typecheck/GHC.Tc.Deriv.Generate.hs) would generate inline code for parsing fields;--- this, however, turned out to produce massive amounts of intermediate code,--- and produced a considerable performance hit in the code generator.--- Since Read instances are not generally supposed to be performance critical,--- the readField and readSymField functions have been factored out, and the--- code generator now just generates calls rather than manually inlining the--- parsers. For large record types (e.g. 500 fields), this produces a--- significant performance boost.------ See also #14364.-------------------------------------------------------------------- Simple instances of Read------------------------------------------------------------------- | @since 2.01-deriving instance Read GeneralCategory---- | @since 2.01-instance Read Char where-  readPrec =-    parens-    ( do L.Char c <- lexP-         return c-    )--  readListPrec =-    parens-    ( do L.String s <- lexP     -- Looks for "foo"-         return s-     +++-      readListPrecDefault       -- Looks for ['f','o','o']-    )                           -- (more generous than H2010 spec)--  readList = readListDefault---- | @since 2.01-instance Read Bool where-  readPrec =-    parens-    ( do L.Ident s <- lexP-         case s of-           "True"  -> return True-           "False" -> return False-           _       -> pfail-    )--  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance Read Ordering where-  readPrec =-    parens-    ( do L.Ident s <- lexP-         case s of-           "LT" -> return LT-           "EQ" -> return EQ-           "GT" -> return GT-           _    -> pfail-    )--  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 4.11.0.0-deriving instance Read a => Read (NonEmpty a)------------------------------------------------------------------- Structure instances of Read: Maybe, List etc-----------------------------------------------------------------{--For structured instances of Read we start using the precedences.  The-idea is then that 'parens (prec k p)' will fail immediately when trying-to parse it in a context with a higher precedence level than k. But if-there is one parenthesis parsed, then the required precedence level-drops to 0 again, and parsing inside p may succeed.--'appPrec' is just the precedence level of function application.  So,-if we are parsing function application, we'd better require the-precedence level to be at least 'appPrec'. Otherwise, we have to put-parentheses around it.--'step' is used to increase the precedence levels inside a-parser, and can be used to express left- or right- associativity. For-example, % is defined to be left associative, so we only increase-precedence on the right hand side.--Note how step is used in for example the Maybe parser to increase the-precedence beyond appPrec, so that basically only literals and-parenthesis-like objects such as (...) and [...] can be an argument to-'Just'.--}---- | @since 2.01-instance Read a => Read (Maybe a) where-  readPrec =-    parens-    (do expectP (L.Ident "Nothing")-        return Nothing-     +++-     prec appPrec (-        do expectP (L.Ident "Just")-           x <- step readPrec-           return (Just x))-    )--  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance Read a => Read [a] where-  {-# SPECIALISE instance Read [String] #-}-  {-# SPECIALISE instance Read [Char] #-}-  {-# SPECIALISE instance Read [Int] #-}-  readPrec     = readListPrec-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance  (Ix a, Read a, Read b) => Read (Array a b)  where-    readPrec = parens $ prec appPrec $-               do expectP (L.Ident "array")-                  theBounds <- step readPrec-                  vals   <- step readPrec-                  return (array theBounds vals)--    readListPrec = readListPrecDefault-    readList     = readListDefault---- | @since 2.01-instance Read L.Lexeme where-  readPrec     = lexP-  readListPrec = readListPrecDefault-  readList     = readListDefault------------------------------------------------------------------- Numeric instances of Read-----------------------------------------------------------------readNumber :: Num a => (L.Lexeme -> ReadPrec a) -> ReadPrec a--- Read a signed number-readNumber convert =-  parens-  ( do x <- lexP-       case x of-         L.Symbol "-" -> do y <- lexP-                            n <- convert y-                            return (negate n)--         _   -> convert x-  )---convertInt :: Num a => L.Lexeme -> ReadPrec a-convertInt (L.Number n)- | Just i <- L.numberToInteger n = return (fromInteger i)-convertInt _ = pfail--convertFrac :: forall a . RealFloat a => L.Lexeme -> ReadPrec a-convertFrac (L.Ident "NaN")      = return (0 / 0)-convertFrac (L.Ident "Infinity") = return (1 / 0)-convertFrac (L.Number n) = let resRange = floatRange (undefined :: a)-                           in case L.numberToRangedRational resRange n of-                              Nothing -> return (1 / 0)-                              Just rat -> return $ fromRational rat-convertFrac _            = pfail---- | @since 2.01-instance Read Int where-  readPrec     = readNumber convertInt-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 4.5.0.0-instance Read Word where-    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Read Word8 where-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Read Word16 where-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Read Word32 where-#if WORD_SIZE_IN_BITS < 33-    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]-#else-    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]-#endif---- | @since 2.01-instance Read Word64 where-    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]---- | @since 2.01-instance Read Integer where-  readPrec     = readNumber convertInt-  readListPrec = readListPrecDefault-  readList     = readListDefault----- | @since 4.8.0.0-instance Read Natural where-  readsPrec d = map (\(n, s) -> (fromInteger n, s))-                  . filter ((>= 0) . (\(x,_)->x)) . readsPrec d---- | @since 2.01-instance Read Float where-  readPrec     = readNumber convertFrac-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance Read Double where-  readPrec     = readNumber convertFrac-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Integral a, Read a) => Read (Ratio a) where-  readPrec =-    parens-    ( prec ratioPrec-      ( do x <- step readPrec-           expectP (L.Symbol "%")-           y <- step readPrec-           return (x % y)-      )-    )--  readListPrec = readListPrecDefault-  readList     = readListDefault------------------------------------------------------------------------------ Tuple instances of Read, up to size 15----------------------------------------------------------------------------- | @since 2.01-instance Read () where-  readPrec =-    parens-    ( paren-      ( return ()-      )-    )--  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 4.15-deriving instance Read a => Read (Solo a)---- | @since 2.01-instance (Read a, Read b) => Read (a,b) where-  readPrec = wrap_tup read_tup2-  readListPrec = readListPrecDefault-  readList     = readListDefault--wrap_tup :: ReadPrec a -> ReadPrec a-wrap_tup p = parens (paren p)--read_comma :: ReadPrec ()-read_comma = expectP (L.Punc ",")--read_tup2 :: (Read a, Read b) => ReadPrec (a,b)--- Reads "a , b"  no parens!-read_tup2 = do x <- readPrec-               read_comma-               y <- readPrec-               return (x,y)--read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d)-read_tup4 = do  (a,b) <- read_tup2-                read_comma-                (c,d) <- read_tup2-                return (a,b,c,d)---read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)-          => ReadPrec (a,b,c,d,e,f,g,h)-read_tup8 = do  (a,b,c,d) <- read_tup4-                read_comma-                (e,f,g,h) <- read_tup4-                return (a,b,c,d,e,f,g,h)----- | @since 2.01-instance (Read a, Read b, Read c) => Read (a, b, c) where-  readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma-                          ; c <- readPrec-                          ; return (a,b,c) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where-  readPrec = wrap_tup read_tup4-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where-  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma-                          ; e <- readPrec-                          ; return (a,b,c,d,e) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f)-        => Read (a, b, c, d, e, f) where-  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma-                          ; (e,f) <- read_tup2-                          ; return (a,b,c,d,e,f) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g)-        => Read (a, b, c, d, e, f, g) where-  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma-                          ; (e,f) <- read_tup2; read_comma-                          ; g <- readPrec-                          ; return (a,b,c,d,e,f,g) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)-        => Read (a, b, c, d, e, f, g, h) where-  readPrec     = wrap_tup read_tup8-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i)-        => Read (a, b, c, d, e, f, g, h, i) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; i <- readPrec-                          ; return (a,b,c,d,e,f,g,h,i) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i, Read j)-        => Read (a, b, c, d, e, f, g, h, i, j) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; (i,j) <- read_tup2-                          ; return (a,b,c,d,e,f,g,h,i,j) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i, Read j, Read k)-        => Read (a, b, c, d, e, f, g, h, i, j, k) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; (i,j) <- read_tup2; read_comma-                          ; k <- readPrec-                          ; return (a,b,c,d,e,f,g,h,i,j,k) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i, Read j, Read k, Read l)-        => Read (a, b, c, d, e, f, g, h, i, j, k, l) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; (i,j,k,l) <- read_tup4-                          ; return (a,b,c,d,e,f,g,h,i,j,k,l) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i, Read j, Read k, Read l, Read m)-        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; (i,j,k,l) <- read_tup4; read_comma-                          ; m <- readPrec-                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i, Read j, Read k, Read l, Read m, Read n)-        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; (i,j,k,l) <- read_tup4; read_comma-                          ; (m,n) <- read_tup2-                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })-  readListPrec = readListPrecDefault-  readList     = readListDefault---- | @since 2.01-instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,-          Read i, Read j, Read k, Read l, Read m, Read n, Read o)-        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma-                          ; (i,j,k,l) <- read_tup4; read_comma-                          ; (m,n) <- read_tup2; read_comma-                          ; o <- readPrec-                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })-  readListPrec = readListPrecDefault-  readList     = readListDefault
− GHC/Real.hs 
@@ -1,817 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, BangPatterns #-}-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Real--- 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)------ The types 'Ratio' and 'Rational', and the classes 'Real', 'Fractional',--- 'Integral', and 'RealFrac'.-----------------------------------------------------------------------------------module GHC.Real where--#include "MachDeps.h"--import GHC.Base-import GHC.Num-import GHC.List-import GHC.Enum-import GHC.Show-import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException-                                   , underflowException-                                   , ratioZeroDenomException )--import GHC.Num.BigNat (gcdInt,gcdWord)--infixr 8  ^, ^^-infixl 7  /, `quot`, `rem`, `div`, `mod`-infixl 7  %--default ()              -- Double isn't available yet,-                        -- and we shouldn't be using defaults anyway----------------------------------------------------------------------------- Divide by zero and arithmetic overflow----------------------------------------------------------------------------- We put them here because they are needed relatively early--- in the libraries before the Exception type has been defined yet.--{-# NOINLINE divZeroError #-}-divZeroError :: a-divZeroError = raise# divZeroException--{-# NOINLINE ratioZeroDenominatorError #-}-ratioZeroDenominatorError :: a-ratioZeroDenominatorError = raise# ratioZeroDenomException--{-# NOINLINE overflowError #-}-overflowError :: a-overflowError = raise# overflowException--{-# NOINLINE underflowError #-}-underflowError :: a-underflowError = raise# underflowException-------------------------------------------------------------------- The Ratio and Rational types------------------------------------------------------------------- | Rational numbers, with numerator and denominator of some 'Integral' type.------ Note that `Ratio`'s instances inherit the deficiencies from the type--- parameter's. For example, @Ratio Natural@'s 'Num' instance has similar--- problems to `Numeric.Natural.Natural`'s.-data  Ratio a = !a :% !a  deriving Eq -- ^ @since 2.01---- | Arbitrary-precision rational numbers, represented as a ratio of--- two 'Integer' values.  A rational number may be constructed using--- the '%' operator.-type  Rational          =  Ratio Integer--ratioPrec, ratioPrec1 :: Int-ratioPrec  = 7  -- Precedence of ':%' constructor-ratioPrec1 = ratioPrec + 1--infinity, notANumber :: Rational-infinity   = 1 :% 0-notANumber = 0 :% 0---- Use :%, not % for Inf/NaN; the latter would--- immediately lead to a runtime error, because it normalises.---- | Forms the ratio of two integral numbers.-{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}-(%)                     :: (Integral a) => a -> a -> Ratio a---- | Extract the numerator of the ratio in reduced form:--- the numerator and denominator have no common factor and the denominator--- is positive.-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     :: Ratio a -> a----- | 'reduce' is a subsidiary function used only in this module.--- It normalises a ratio by dividing both numerator and denominator by--- their greatest common divisor.-reduce ::  (Integral a) => a -> a -> Ratio a-{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}-reduce _ 0              =  ratioZeroDenominatorError-reduce x y              =  (x `quot` d) :% (y `quot` d)-                           where d = gcd x y--x % y                   =  reduce (x * signum y) (abs y)--numerator   (x :% _)    =  x-denominator (_ :% y)    =  y------------------------------------------------------------------- Standard numeric classes-----------------------------------------------------------------class  (Num a, Ord a) => Real a  where-    -- | the rational equivalent of its real argument with full precision-    toRational          ::  a -> Rational---- | Integral numbers, supporting integer division.------ The Haskell Report defines no laws for 'Integral'. However, 'Integral'--- instances are customarily expected to define a Euclidean domain and have the--- following properties for the 'div'\/'mod' and 'quot'\/'rem' pairs, given--- suitable Euclidean functions @f@ and @g@:------ * @x@ = @y * quot x y + rem x y@ with @rem x y@ = @fromInteger 0@ or--- @g (rem x y)@ < @g y@--- * @x@ = @y * div x y + mod x y@ with @mod x y@ = @fromInteger 0@ or--- @f (mod x y)@ < @f y@------ An example of a suitable Euclidean function, for 'Integer'\'s instance, is--- 'abs'.-class  (Real a, Enum a) => Integral a  where-    -- | integer division truncated toward zero-    quot                :: a -> a -> a-    -- | integer remainder, satisfying-    ---    -- > (x `quot` y)*y + (x `rem` y) == x-    rem                 :: a -> a -> a-    -- | integer division truncated toward negative infinity-    div                 :: a -> a -> a-    -- | integer modulus, satisfying-    ---    -- > (x `div` y)*y + (x `mod` y) == x-    mod                 :: a -> a -> a-    -- | simultaneous 'quot' and 'rem'-    quotRem             :: a -> a -> (a,a)-    -- | simultaneous 'div' and 'mod'-    divMod              :: a -> a -> (a,a)-    -- | conversion to 'Integer'-    toInteger           :: a -> Integer--    {-# INLINE quot #-}-    {-# INLINE rem #-}-    {-# INLINE div #-}-    {-# INLINE mod #-}-    n `quot` d          =  q  where (q,_) = quotRem n d-    n `rem` d           =  r  where (_,r) = quotRem n d-    n `div` d           =  q  where (q,_) = divMod n d-    n `mod` d           =  r  where (_,r) = divMod n d--    divMod n d          =  if signum r == negate (signum d) then (q-1, r+d) else qr-                           where qr@(q,r) = quotRem n d---- | Fractional numbers, supporting real division.------ The Haskell Report defines no laws for 'Fractional'. However, @('+')@ and--- @('*')@ are customarily expected to define a division ring and have the--- following properties:------ [__'recip' gives the multiplicative inverse__]:--- @x * recip x@ = @recip x * x@ = @fromInteger 1@------ Note that it /isn't/ customarily expected that a type instance of--- 'Fractional' implement a field. However, all instances in @base@ do.-class  (Num a) => Fractional a  where-    {-# MINIMAL fromRational, (recip | (/)) #-}--    -- | Fractional division.-    (/)                 :: a -> a -> a-    -- | Reciprocal fraction.-    recip               :: a -> a-    -- | Conversion from a 'Rational' (that is @'Ratio' 'Integer'@).-    -- A floating literal stands for an application of 'fromRational'-    -- to a value of type 'Rational', so such literals have type-    -- @('Fractional' a) => a@.-    fromRational        :: Rational -> a--    {-# INLINE recip #-}-    {-# INLINE (/) #-}-    recip x             =  1 / x-    x / y               = x * recip y---- | Extracting components of fractions.-class  (Real a, Fractional a) => RealFrac a  where-    -- | The function 'properFraction' takes a real fractional number @x@-    -- and returns a pair @(n,f)@ such that @x = n+f@, and:-    ---    -- * @n@ is an integral number with the same sign as @x@; and-    ---    -- * @f@ is a fraction with the same type and sign as @x@,-    --   and with absolute value less than @1@.-    ---    -- The default definitions of the 'ceiling', 'floor', 'truncate'-    -- and 'round' functions are in terms of 'properFraction'.-    properFraction      :: (Integral b) => a -> (b,a)-    -- | @'truncate' x@ returns the integer nearest @x@ between zero and @x@-    truncate            :: (Integral b) => a -> b-    -- | @'round' x@ returns the nearest integer to @x@;-    --   the even integer if @x@ is equidistant between two integers-    round               :: (Integral b) => a -> b-    -- | @'ceiling' x@ returns the least integer not less than @x@-    ceiling             :: (Integral b) => a -> b-    -- | @'floor' x@ returns the greatest integer not greater than @x@-    floor               :: (Integral b) => a -> b--    {-# INLINE truncate #-}-    truncate x          =  m  where (m,_) = properFraction x--    round x             =  let (n,r) = properFraction x-                               m     = if r < 0 then n - 1 else n + 1-                           in case signum (abs r - 0.5) of-                                -1 -> n-                                0  -> if even n then n else m-                                1  -> m-                                _  -> errorWithoutStackTrace "round default defn: Bad value"--    ceiling x           =  if r > 0 then n + 1 else n-                           where (n,r) = properFraction x--    floor x             =  if r < 0 then n - 1 else n-                           where (n,r) = properFraction x---- These 'numeric' enumerations come straight from the Report--numericEnumFrom         :: (Fractional a) => a -> [a]-numericEnumFrom n       = go 0-  where-    -- See Note [Numeric Stability of Enumerating Floating Numbers]-    go !k = let !n' = n + k-             in n' : go (k + 1)--numericEnumFromThen     :: (Fractional a) => a -> a -> [a]-numericEnumFromThen n m = go 0-  where-    step = m - n-    -- See Note [Numeric Stability of Enumerating Floating Numbers]-    go !k = let !n' = n + k * step-             in n' : go (k + 1)--numericEnumFromTo       :: (Ord a, Fractional a) => a -> a -> [a]-numericEnumFromTo n m   = takeWhile (<= m + 1/2) (numericEnumFrom n)--numericEnumFromThenTo   :: (Ord a, Fractional a) => a -> a -> a -> [a]-numericEnumFromThenTo e1 e2 e3-    = takeWhile predicate (numericEnumFromThen e1 e2)-                                where-                                 mid = (e2 - e1) / 2-                                 predicate | e2 >= e1  = (<= e3 + mid)-                                           | otherwise = (>= e3 + mid)--{- Note [Numeric Stability of Enumerating Floating Numbers]-------------------------------------------------------------When enumerate floating numbers, we could add the increment to the last number-at every run (as what we did previously):--    numericEnumFrom n =  n `seq` (n : numericEnumFrom (n + 1))--This approach is concise and really fast, only needs an addition operation.-However when a floating number is large enough, for `n`, `n` and `n+1` will-have the same binary representation. For example (all number has type-`Double`):--    9007199254740990                 is: 0x433ffffffffffffe-    9007199254740990 + 1             is: 0x433fffffffffffff-    (9007199254740990 + 1) + 1       is: 0x4340000000000000-    ((9007199254740990 + 1) + 1) + 1 is: 0x4340000000000000--When we evaluate ([9007199254740990..9007199254740991] :: Double), we would-never reach the condition in `numericEnumFromTo`--    9007199254740990 + 1 + 1 + ... > 9007199254740991 + 1/2--We would fall into infinite loop (as reported in #15081).--To remedy the situation, we record the number of `1` that needed to be added-to the start number, rather than increasing `1` at every time. This approach-can improvement the numeric stability greatly at the cost of a multiplication.--Furthermore, we use the type of the enumerated number, `Fractional a => a`,-as the type of multiplier. In rare situations, the multiplier could be very-large and will lead to the enumeration to infinite loop, too, which should-be very rare. Consider the following example:--    [1..9007199254740994]--We could fix that by using an Integer as multiplier but we don't do that.-The benchmark on T7954.hs shows that this approach leads to significant-degeneration on performance (33% increase allocation and 300% increase on-elapsed time).--See #15081 and Phab:D4650 for the related discussion about this problem.--}------------------------------------------------------------------- Instances for Int------------------------------------------------------------------- | @since 2.0.1-instance  Real Int  where-    toRational x        =  toInteger x :% 1---- | @since 2.0.1-instance  Integral Int  where-    toInteger (I# i) = IS i--    a `quot` b-     | b == 0                     = divZeroError-     | b == (-1) && a == minBound = overflowError -- Note [Order of tests]-                                                  -- in GHC.Int-     | otherwise                  =  a `quotInt` b--    !a `rem` b -- See Note [Special case of mod and rem is lazy]-     | b == 0                     = divZeroError-     | b == (-1)                  = 0-     | otherwise                  =  a `remInt` b--    a `div` b-     | b == 0                     = divZeroError-     | b == (-1) && a == minBound = overflowError -- Note [Order of tests]-                                                  -- in GHC.Int-     | otherwise                  =  a `divInt` b--    !a `mod` b -- See Note [Special case of mod and rem is lazy]-     | b == 0                     = divZeroError-     | b == (-1)                  = 0-     | otherwise                  =  a `modInt` b--    a `quotRem` b-     | b == 0                     = divZeroError-       -- Note [Order of tests] in GHC.Int-     | b == (-1) && a == minBound = (overflowError, 0)-     | otherwise                  =  a `quotRemInt` b--    a `divMod` b-     | b == 0                     = divZeroError-       -- Note [Order of tests] in GHC.Int-     | b == (-1) && a == minBound = (overflowError, 0)-     | otherwise                  =  a `divModInt` b--{- Note [Special case of mod and rem is lazy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The `quotRem`/`divMod` CPU instruction fails for minBound `quotRem` -1, but-minBound `rem` -1 is well-defined (0). We therefore special-case for `b == -1`,-but not for `a == minBound` because of Note [Order of tests] in GHC.Int. But-now we have to make sure the function stays strict in a, to guarantee unboxing.-Hence the bang on a, see #18187.--}------------------------------------------------------------------- Instances for @Word@------------------------------------------------------------------- | @since 2.01-instance Real Word where-    toRational x = toInteger x % 1---- | @since 2.01-instance Integral Word where-    quot    (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `quotWord#` y#)-        | otherwise             = divZeroError-    rem     (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `remWord#` y#)-        | otherwise             = divZeroError-    div     (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `quotWord#` y#)-        | otherwise             = divZeroError-    mod     (W# x#) y@(W# y#)-        | y /= 0                = W# (x# `remWord#` y#)-        | otherwise             = divZeroError-    quotRem (W# x#) y@(W# y#)-        | y /= 0                = case x# `quotRemWord#` y# of-                                  (# q, r #) ->-                                      (W# q, W# r)-        | otherwise             = divZeroError-    divMod  (W# x#) y@(W# y#)-        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))-        | otherwise             = divZeroError-    toInteger (W# x#)           = integerFromWord# x#------------------------------------------------------------------- Instances for Integer------------------------------------------------------------------- | @since 2.0.1-instance  Real Integer  where-    toRational x        =  x :% 1---- | @since 4.8.0.0-instance Real Natural where-    toRational n = integerFromNatural n :% 1---- Note [Integer division constant folding]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Constant folding of quot, rem, div, mod, divMod and quotRem for Integer--- arguments depends crucially on inlining. Constant folding rules defined in--- GHC.Core.Opt.ConstantFold trigger for integerQuot, integerRem and so on.--- So if calls to quot, rem and so on were not inlined the rules would not fire.------ The rules would also not fire if calls to integerQuot and so on were inlined,--- but this does not happen because they are all marked with NOINLINE pragma.----- | @since 2.0.1-instance  Integral Integer where-    toInteger n      = n--    {-# INLINE quot #-}-    _ `quot` 0 = divZeroError-    n `quot` d = n `integerQuot` d--    {-# INLINE rem #-}-    _ `rem` 0 = divZeroError-    n `rem` d = n `integerRem` d--    {-# INLINE div #-}-    _ `div` 0 = divZeroError-    n `div` d = n `integerDiv` d--    {-# INLINE mod #-}-    _ `mod` 0 = divZeroError-    n `mod` d = n `integerMod` d--    {-# INLINE divMod #-}-    _ `divMod` 0 = divZeroError-    n `divMod` d = n `integerDivMod` d--    {-# INLINE quotRem #-}-    _ `quotRem` 0 = divZeroError-    n `quotRem` d = n `integerQuotRem` d---- | @since 4.8.0.0-instance Integral Natural where-    toInteger x = integerFromNatural x--    {-# INLINE quot #-}-    _ `quot` 0 = divZeroError-    n `quot` d = n `naturalQuot` d--    {-# INLINE rem #-}-    _ `rem` 0 = divZeroError-    n `rem` d = n `naturalRem` d--    {-# INLINE div #-}-    _ `div` 0 = divZeroError-    n `div` d = n `naturalQuot` d--    {-# INLINE mod #-}-    _ `mod` 0 = divZeroError-    n `mod` d = n `naturalRem` d--    {-# INLINE divMod #-}-    _ `divMod` 0 = divZeroError-    n `divMod` d = n `naturalQuotRem` d--    {-# INLINE quotRem #-}-    _ `quotRem` 0 = divZeroError-    n `quotRem` d = n `naturalQuotRem` d------------------------------------------------------------------- Instances for @Ratio@------------------------------------------------------------------- | @since 2.0.1-instance  (Integral a)  => Ord (Ratio a)  where-    {-# SPECIALIZE instance Ord Rational #-}-    (x:%y) <= (x':%y')  =  x * y' <= x' * y-    (x:%y) <  (x':%y')  =  x * y' <  x' * y---- | @since 2.0.1-instance  (Integral a)  => Num (Ratio a)  where-    {-# SPECIALIZE instance Num Rational #-}-    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')-    (x:%y) - (x':%y')   =  reduce (x*y' - x'*y) (y*y')-    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')-    negate (x:%y)       =  (-x) :% y-    abs (x:%y)          =  abs x :% y-    signum (x:%_)       =  signum x :% 1-    fromInteger x       =  fromInteger x :% 1---- | @since 2.0.1-{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}-instance  (Integral a)  => Fractional (Ratio a)  where-    {-# SPECIALIZE instance Fractional Rational #-}-    (x:%y) / (x':%y')   =  (x*y') % (y*x')-    recip (0:%_)        = ratioZeroDenominatorError-    recip (x:%y)-        | x < 0         = negate y :% negate x-        | otherwise     = y :% x-    fromRational (x:%y) =  fromInteger x % fromInteger y---- | @since 2.0.1-instance  (Integral a)  => Real (Ratio a)  where-    {-# SPECIALIZE instance Real Rational #-}-    toRational (x:%y)   =  toInteger x :% toInteger y---- | @since 2.0.1-instance  (Integral a)  => RealFrac (Ratio a)  where-    {-# SPECIALIZE instance RealFrac Rational #-}-    properFraction (x:%y) = (fromInteger (toInteger q), r:%y)-                          where (q,r) = quotRem x y-    round r =-      let-        (n, f) = properFraction r-        x = if r < 0 then -1 else 1-      in-        case (compare (abs f) 0.5, odd n) of-          (LT, _) -> n-          (EQ, False) -> n-          (EQ, True) -> n + x-          (GT, _) -> n + x---- | @since 2.0.1-instance  (Show a)  => Show (Ratio a)  where-    {-# SPECIALIZE instance Show Rational #-}-    showsPrec p (x:%y)  =  showParen (p > ratioPrec) $-                           showsPrec ratioPrec1 x .-                           showString " % " .-                           -- H98 report has spaces round the %-                           -- but we removed them [May 04]-                           -- and added them again for consistency with-                           -- Haskell 98 [Sep 08, #1920]-                           showsPrec ratioPrec1 y---- | @since 2.0.1-instance  (Integral a)  => Enum (Ratio a)  where-    {-# SPECIALIZE instance Enum Rational #-}-    succ x              =  x + 1-    pred x              =  x - 1--    toEnum n            =  fromIntegral n :% 1-    fromEnum            =  fromInteger . truncate--    enumFrom            =  numericEnumFrom-    enumFromThen        =  numericEnumFromThen-    enumFromTo          =  numericEnumFromTo-    enumFromThenTo      =  numericEnumFromThenTo------------------------------------------------------------------- Coercions------------------------------------------------------------------- | general coercion from integral types-{-# INLINE fromIntegral #-}-  -- Inlined to allow built-in rules to match.-  -- See Note [Optimising conversions between numeric types]-  -- in GHC.Core.Opt.ConstantFold-fromIntegral :: (Integral a, Num b) => a -> b-fromIntegral = fromInteger . toInteger---- | general coercion to fractional types-realToFrac :: (Real a, Fractional b) => a -> b-{-# NOINLINE [1] realToFrac #-}-realToFrac = fromRational . toRational------------------------------------------------------------------- Overloaded numeric functions------------------------------------------------------------------- | Converts a possibly-negative 'Real' value to a string.-showSigned :: (Real a)-  => (a -> ShowS)       -- ^ a function that can show unsigned values-  -> Int                -- ^ the precedence of the enclosing context-  -> a                  -- ^ the value to show-  -> ShowS-showSigned showPos p x-   | x < 0     = showParen (p > 6) (showChar '-' . showPos (-x))-   | otherwise = showPos x--even, odd       :: (Integral a) => a -> Bool-even n          =  n `rem` 2 == 0-odd             =  not . even-{-# INLINABLE even #-}-{-# INLINABLE odd  #-}------------------------------------------------------------ | raise a number to a non-negative integral power-{-# SPECIALISE [1] (^) ::-        Integer -> Integer -> Integer,-        Integer -> Int -> Integer,-        Int -> Int -> Int #-}-{-# INLINABLE [1] (^) #-}    -- See Note [Inlining (^)]-(^) :: (Num a, Integral b) => a -> b -> a-x0 ^ y0 | y0 < 0    = errorWithoutStackTrace "Negative exponent"-        | y0 == 0   = 1-        | otherwise = f x0 y0-    where -- f : x0 ^ y0 = x ^ y-          f x y | even y    = f (x * x) (y `quot` 2)-                | y == 1    = x-                | otherwise = g (x * x) (y `quot` 2) x         -- See Note [Half of y - 1]-          -- g : x0 ^ y0 = (x ^ y) * z-          g x y z | even y = g (x * x) (y `quot` 2) z-                  | y == 1 = x * z-                  | otherwise = g (x * x) (y `quot` 2) (x * z) -- See Note [Half of y - 1]---- | raise a number to an integral power-(^^)            :: (Fractional a, Integral b) => a -> b -> a-{-# INLINABLE [1] (^^) #-}         -- See Note [Inlining (^)-x ^^ n          =  if n >= 0 then x^n else recip (x^(negate n))--{- Note [Half of y - 1]-   ~~~~~~~~~~~~~~~~~~~~~-   Since y is guaranteed to be odd and positive here,-   half of y - 1 can be computed as y `quot` 2, optimising subtraction away.--}--{- Note [Inlining (^)-   ~~~~~~~~~~~~~~~~~~~~~-   The INLINABLE pragma allows (^) to be specialised at its call sites.-   If it is called repeatedly at the same type, that can make a huge-   difference, because of those constants which can be repeatedly-   calculated.--   Currently the fromInteger calls are not floated because we get-             \d1 d2 x y -> blah-   after the gentle round of simplification. -}--{- Rules for powers with known small exponent-    see #5237-    For small exponents, (^) is inefficient compared to manually-    expanding the multiplication tree.-    Here, rules for the most common exponent types are given.-    The range of exponents for which rules are given is quite-    arbitrary and kept small to not unduly increase the number of rules.-    0 and 1 are excluded based on the assumption that nobody would-    write x^0 or x^1 in code and the cases where an exponent could-    be statically resolved to 0 or 1 are rare.--    It might be desirable to have corresponding rules also for-    exponents of other types (e. g., Word), but it's doubtful they-    would fire, since the exponents of other types tend to get-    floated out before the rule has a chance to fire.--    Also desirable would be rules for (^^), but I haven't managed-    to get those to fire.--    Note: Trying to save multiplications by sharing the square for-    exponents 4 and 5 does not save time, indeed, for Double, it is-    up to twice slower, so the rules contain flat sequences of-    multiplications.--}--{-# RULES-"^2/Int"        forall x. x ^ (2 :: Int) = let u = x in u*u-"^3/Int"        forall x. x ^ (3 :: Int) = let u = x in u*u*u-"^4/Int"        forall x. x ^ (4 :: Int) = let u = x in u*u*u*u-"^5/Int"        forall x. x ^ (5 :: Int) = let u = x in u*u*u*u*u-"^2/Integer"    forall x. x ^ (2 :: Integer) = let u = x in u*u-"^3/Integer"    forall x. x ^ (3 :: Integer) = let u = x in u*u*u-"^4/Integer"    forall x. x ^ (4 :: Integer) = let u = x in u*u*u*u-"^5/Integer"    forall x. x ^ (5 :: Integer) = let u = x in u*u*u*u*u-  #-}------------------------------------------------------------ Special power functions for Rational------ see #4337------ Rationale:--- For a legitimate Rational (n :% d), the numerator and denominator are--- coprime, i.e. they have no common prime factor.--- Therefore all powers (n ^ a) and (d ^ b) are also coprime, so it is--- not necessary to compute the greatest common divisor, which would be--- done in the default implementation at each multiplication step.--- Since exponentiation quickly leads to very large numbers and--- calculation of gcds is generally very slow for large numbers,--- avoiding the gcd leads to an order of magnitude speedup relatively--- soon (and an asymptotic improvement overall).------ Note:--- We cannot use these functions for general Ratio a because that would--- change results in a multitude of cases.--- The cause is that if a and b are coprime, their remainders by any--- positive modulus generally aren't, so in the default implementation--- reduction occurs.------ Example:--- (17 % 3) ^ 3 :: Ratio Word8--- Default:--- (17 % 3) ^ 3 = ((17 % 3) ^ 2) * (17 % 3)---              = ((289 `mod` 256) % 9) * (17 % 3)---              = (33 % 9) * (17 % 3)---              = (11 % 3) * (17 % 3)---              = (187 % 9)--- But:--- ((17^3) `mod` 256) % (3^3)   = (4913 `mod` 256) % 27---                              = 49 % 27------ TODO:--- Find out whether special-casing for numerator, denominator or--- exponent = 1 (or -1, where that may apply) gains something.---- Special version of (^) for Rational base-{-# RULES "(^)/Rational"    (^) = (^%^) #-}-(^%^)           :: Integral a => Rational -> a -> Rational-(n :% d) ^%^ e-    | e < 0     = errorWithoutStackTrace "Negative exponent"-    | e == 0    = 1 :% 1-    | otherwise = (n ^ e) :% (d ^ e)---- Special version of (^^) for Rational base-{-# RULES "(^^)/Rational"   (^^) = (^^%^^) #-}-(^^%^^)         :: Integral a => Rational -> a -> Rational-(n :% d) ^^%^^ e-    | e > 0     = (n ^ e) :% (d ^ e)-    | e == 0    = 1 :% 1-    | n > 0     = (d ^ (negate e)) :% (n ^ (negate e))-    | n == 0    = ratioZeroDenominatorError-    | otherwise = let nn = d ^ (negate e)-                      dd = (negate n) ^ (negate e)-                  in if even e then (nn :% dd) else (negate nn :% dd)------------------------------------------------------------ | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which--- every common factor of @x@ and @y@ is also a factor; for example--- @'gcd' 4 2 = 2@, @'gcd' (-4) 6 = 2@, @'gcd' 0 4@ = @4@. @'gcd' 0 0@ = @0@.--- (That is, the common divisor that is \"greatest\" in the divisibility--- preordering.)------ Note: Since for signed fixed-width integer types, @'abs' 'minBound' < 0@,--- the result may be negative if one of the arguments is @'minBound'@ (and--- necessarily is if the other is @0@ or @'minBound'@) for such types.-gcd             :: (Integral a) => a -> a -> a-{-# NOINLINE [1] gcd #-}-gcd x y         =  gcd' (abs x) (abs y)-                   where gcd' a 0  =  a-                         gcd' a b  =  gcd' b (a `rem` b)---- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.-lcm             :: (Integral a) => a -> a -> a-{-# SPECIALISE lcm :: Int -> Int -> Int #-}-{-# SPECIALISE lcm :: Word -> Word -> Word #-}-{-# NOINLINE [1] lcm #-}-lcm _ 0         =  0-lcm 0 _         =  0-lcm x y         =  abs ((x `quot` (gcd x y)) * y)--{-# RULES-"gcd/Integer->Integer->Integer" gcd = integerGcd-"lcm/Integer->Integer->Integer" lcm = integerLcm-"gcd/Natural->Natural->Natural" gcd = naturalGcd-"lcm/Natural->Natural->Natural" lcm = naturalLcm- #-}--{-# RULES-"gcd/Int->Int->Int"             gcd = gcdInt-"gcd/Word->Word->Word"          gcd = gcdWord- #-}---- See Note [Stable Unfolding for list producers] in GHC.Enum-{-# INLINABLE integralEnumFrom #-}-integralEnumFrom :: (Integral a, Bounded a) => a -> [a]-integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)]---- See Note [Stable Unfolding for list producers] in GHC.Enum-{-# INLINABLE integralEnumFromThen #-}-integralEnumFromThen :: (Integral a, Bounded a) => a -> a -> [a]-integralEnumFromThen n1 n2-  | i_n2 >= i_n1  = map fromInteger [i_n1, i_n2 .. toInteger (maxBound `asTypeOf` n1)]-  | otherwise     = map fromInteger [i_n1, i_n2 .. toInteger (minBound `asTypeOf` n1)]-  where-    i_n1 = toInteger n1-    i_n2 = toInteger n2---- See Note [Stable Unfolding for list producers] in GHC.Enum-{-# INLINABLE integralEnumFromTo #-}-integralEnumFromTo :: Integral a => a -> a -> [a]-integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m]---- See Note [Stable Unfolding for list producers] in GHC.Enum-{-# INLINABLE integralEnumFromThenTo #-}-integralEnumFromThenTo :: Integral a => a -> a -> a -> [a]-integralEnumFromThenTo n1 n2 m-  = map fromInteger [toInteger n1, toInteger n2 .. toInteger m]---- mkRational related code--data FractionalExponentBase-  = Base2-  | Base10-  deriving (Show)--mkRationalBase2 :: Rational -> Integer -> Rational-mkRationalBase2 r e = mkRationalWithExponentBase r e Base2--mkRationalBase10 :: Rational -> Integer -> Rational-mkRationalBase10 r e = mkRationalWithExponentBase r e Base10--mkRationalWithExponentBase :: Rational -> Integer-                           -> FractionalExponentBase -> Rational-mkRationalWithExponentBase r e feb = r * (eb ^^ e)-  -- See Note [fractional exponent bases] for why only these bases.-  where eb = case feb of Base2 -> 2 ; Base10 -> 10
− GHC/Real.hs-boot 
@@ -1,7 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module GHC.Real where--import GHC.Types ()--class Integral a
− GHC/Records.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Records--- Copyright   :  (c) Adam Gundry 2015-2016--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ This module defines the 'HasField' class used by the--- @OverloadedRecordFields@ extension.  See the--- <https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields--- wiki page> for more details.-----------------------------------------------------------------------------------module GHC.Records-       ( HasField(..)-       ) where---- | Constraint representing the fact that the field @x@ belongs to--- the record type @r@ and has field type @a@.  This will be solved--- automatically, but manual instances may be provided as well.----   HasField :: forall {k}. k -> * -> * -> Constraint---   getField :: forall {k} (x::k) r a. HasField x r a => r -> a--- NB: The {k} means that k is an 'inferred' type variable, and---     hence not provided in visible type applications.  Thus you---     say     getField @"foo"---     not     getField @Symbol @"foo"-class HasField x r a | x r -> a where-  -- | Selector function to extract the field from the record.-  getField :: r -> a
− GHC/ResponseFile.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.ResponseFile--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  portable------ GCC style response files.------ @since 4.12.0.0--------------------------------------------------------------------------------- Migrated from Haddock.--module GHC.ResponseFile (-    getArgsWithResponseFiles,-    unescapeArgs,-    escapeArgs,-    expandResponse-  ) where--import Control.Exception-import Data.Char          (isSpace)-import Data.Foldable      (foldl')-import System.Environment (getArgs)-import System.Exit        (exitFailure)-import System.IO--{-|-Like 'getArgs', but can also read arguments supplied via response files.---For example, consider a program @foo@:--@-main :: IO ()-main = do-  args <- getArgsWithResponseFiles-  putStrLn (show args)-@---And a response file @args.txt@:--@---one 1---\'two\' 2---"three" 3-@--Then the result of invoking @foo@ with @args.txt@ is:--> > ./foo @args.txt-> ["--one","1","--two","2","--three","3"]---}-getArgsWithResponseFiles :: IO [String]-getArgsWithResponseFiles = getArgs >>= expandResponse---- | Given a string of concatenated strings, separate each by removing--- a layer of /quoting/ and\/or /escaping/ of certain characters.------ These characters are: any whitespace, single quote, double quote,--- and the backslash character.  The backslash character always--- escapes (i.e., passes through without further consideration) the--- character which follows.  Characters can also be escaped in blocks--- by quoting (i.e., surrounding the blocks with matching pairs of--- either single- or double-quotes which are not themselves escaped).------ Any whitespace which appears outside of either of the quoting and--- escaping mechanisms, is interpreted as having been added by this--- special concatenation process to designate where the boundaries--- are between the original, un-concatenated list of strings.  These--- added whitespace characters are removed from the output.------ > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\""-unescapeArgs :: String -> [String]-unescapeArgs = filter (not . null) . unescape---- | Given a list of strings, concatenate them into a single string--- with escaping of certain characters, and the addition of a newline--- between each string.  The escaping is done by adding a single--- backslash character before any whitespace, single quote, double--- quote, or backslash character, so this escaping character must be--- removed.  Unescaped whitespace (in this case, newline) is part--- of this "transport" format to indicate the end of the previous--- string and the start of a new string.------ While 'unescapeArgs' allows using quoting (i.e., convenient--- escaping of many characters) by having matching sets of single- or--- double-quotes,'escapeArgs' does not use the quoting mechasnism,--- and thus will always escape any whitespace, quotes, and--- backslashes.------ > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\""-escapeArgs :: [String] -> String-escapeArgs = unlines . map escapeArg---- | Arguments which look like @\@foo@ will be replaced with the--- contents of file @foo@. A gcc-like syntax for response files arguments--- is expected.  This must re-constitute the argument list by doing an--- inverse of the escaping mechanism done by the calling-program side.------ We quit if the file is not found or reading somehow fails.--- (A convenience routine for haddock or possibly other clients)-expandResponse :: [String] -> IO [String]-expandResponse = fmap concat . mapM expand-  where-    expand :: String -> IO [String]-    expand ('@':f) = readFileExc f >>= return . unescapeArgs-    expand x = return [x]--    readFileExc f =-      readFile f `catch` \(e :: IOException) -> do-        hPutStrLn stderr $ "Error while expanding response file: " ++ show e-        exitFailure--data Quoting = NoneQ | SngQ | DblQ--unescape :: String -> [String]-unescape args = reverse . map reverse $ go args NoneQ False [] []-    where-      -- n.b., the order of these cases matters; these are cribbed from gcc-      -- case 1: end of input-      go []     _q    _bs   a as = a:as-      -- case 2: back-slash escape in progress-      go (c:cs) q     True  a as = go cs q     False (c:a) as-      -- case 3: no back-slash escape in progress, but got a back-slash-      go (c:cs) q     False a as-        | '\\' == c              = go cs q     True  a     as-      -- case 4: single-quote escaping in progress-      go (c:cs) SngQ  False a as-        | '\'' == c              = go cs NoneQ False a     as-        | otherwise              = go cs SngQ  False (c:a) as-      -- case 5: double-quote escaping in progress-      go (c:cs) DblQ  False a as-        | '"' == c               = go cs NoneQ False a     as-        | otherwise              = go cs DblQ  False (c:a) as-      -- case 6: no escaping is in progress-      go (c:cs) NoneQ False a as-        | isSpace c              = go cs NoneQ False []    (a:as)-        | '\'' == c              = go cs SngQ  False a     as-        | '"'  == c              = go cs DblQ  False a     as-        | otherwise              = go cs NoneQ False (c:a) as--escapeArg :: String -> String-escapeArg = reverse . foldl' escape []--escape :: String -> Char -> String-escape cs c-  |    isSpace c-    || '\\' == c-    || '\'' == c-    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result-  | otherwise    = c:cs
− GHC/ST.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RankNTypes #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.ST--- Copyright   :  (c) The University of Glasgow, 1992-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The 'ST' Monad.-----------------------------------------------------------------------------------module GHC.ST (-        ST(..), STret(..), STRep,-        runST,--        -- * Unsafe functions-        liftST, unsafeInterleaveST, unsafeDupableInterleaveST-    ) where--import GHC.Base-import GHC.Show-import Control.Monad.Fail--default ()---- The 'ST' monad proper.  By default the monad is strict;--- too many people got bitten by space leaks when it was lazy.---- | The strict 'ST' monad.--- The 'ST' monad allows for destructive updates, but is escapable (unlike IO).--- A computation of type @'ST' s a@ returns a value of type @a@, and--- execute in "thread" @s@. The @s@ parameter is either------ * an uninstantiated type variable (inside invocations of 'runST'), or------ * 'RealWorld' (inside invocations of 'Control.Monad.ST.stToIO').------ It serves to keep the internal states of different invocations--- of 'runST' separate from each other and from invocations of--- 'Control.Monad.ST.stToIO'.------ The '>>=' and '>>' operations are strict in the state (though not in--- values stored in the state).  For example,------ @'runST' (writeSTRef _|_ v >>= f) = _|_@-newtype ST s a = ST (STRep s a)-type STRep s a = State# s -> (# State# s, a #)---- | @since 2.01-instance Functor (ST s) where-    fmap f (ST m) = ST $ \ s ->-      case (m s) of { (# new_s, r #) ->-      (# new_s, f r #) }---- | @since 4.4.0.0-instance Applicative (ST s) where-    {-# INLINE pure #-}-    {-# INLINE (*>)   #-}-    pure x = ST (\ s -> (# s, x #))-    m *> k = m >>= \ _ -> k-    (<*>) = ap-    liftA2 = liftM2---- | @since 2.01-instance Monad (ST s) where-    {-# INLINE (>>=)  #-}-    (>>) = (*>)-    (ST m) >>= k-      = ST (\ s ->-        case (m s) of { (# new_s, r #) ->-        case (k r) of { ST k2 ->-        (k2 new_s) }})---- | @since 4.11.0.0-instance MonadFail (ST s) where-    fail s = errorWithoutStackTrace s---- | @since 4.11.0.0-instance Semigroup a => Semigroup (ST s a) where-    (<>) = liftA2 (<>)---- | @since 4.11.0.0-instance Monoid a => Monoid (ST s a) where-    mempty = pure mempty--data STret s a = STret (State# s) a---- liftST is useful when we want a lifted result from an ST computation.-liftST :: ST s a -> State# s -> STret s a-liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r--noDuplicateST :: ST s ()-noDuplicateST = ST $ \s -> (# noDuplicate# s, () #)---- | 'unsafeInterleaveST' allows an 'ST' computation to be deferred--- lazily.  When passed a value of type @ST a@, the 'ST' computation will--- only be performed when the value of the @a@ is demanded.-{-# INLINE unsafeInterleaveST #-}-unsafeInterleaveST :: ST s a -> ST s a-unsafeInterleaveST m = unsafeDupableInterleaveST (noDuplicateST >> m)---- | 'unsafeDupableInterleaveST' allows an 'ST' computation to be deferred--- lazily.  When passed a value of type @ST a@, the 'ST' computation will--- only be performed when the value of the @a@ is demanded.------ The computation may be performed multiple times by different threads,--- possibly at the same time. To prevent this, use 'unsafeInterleaveST' instead.------ @since 4.11-{-# NOINLINE unsafeDupableInterleaveST #-}--- See Note [unsafeDupableInterleaveIO should not be inlined]--- in GHC.IO.Unsafe-unsafeDupableInterleaveST :: ST s a -> ST s a-unsafeDupableInterleaveST (ST m) = ST ( \ s ->-    let-        r = case m s of (# _, res #) -> res-    in-    (# s, r #)-  )---- | @since 2.01-instance  Show (ST s a)  where-    showsPrec _ _  = showString "<<ST action>>"-    showList       = showList__ (showsPrec 0)--{-# INLINE runST #-}--- | Return the value computed by a state thread.--- 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 st_rep) = case runRW# st_rep of (# _, a #) -> a--- See Note [Definition of runRW#] in GHC.Magic
− GHC/STRef.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.STRef--- 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)------ References in the 'ST' monad.-----------------------------------------------------------------------------------module GHC.STRef (-        STRef(..),-        newSTRef, readSTRef, writeSTRef-    ) where--import GHC.ST-import GHC.Base---- $setup--- >>> import Prelude--- >>> import Control.Monad.ST--data STRef s a = STRef (MutVar# s a)--- ^ a value of type @STRef s a@ is a mutable variable in state thread @s@,--- containing a value of type @a@------ >>> :{--- runST (do---     ref <- newSTRef "hello"---     x <- readSTRef ref---     writeSTRef ref (x ++ "world")---     readSTRef ref )--- :}--- "helloworld"---- |Build a new 'STRef' in the current state thread-newSTRef :: a -> ST s (STRef s a)-newSTRef init = ST $ \s1# ->-    case newMutVar# init s1#            of { (# s2#, var# #) ->-    (# s2#, STRef var# #) }---- |Read the value of an 'STRef'-readSTRef :: STRef s a -> ST s a-readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1#---- |Write a new value into an 'STRef'-writeSTRef :: STRef s a -> a -> ST s ()-writeSTRef (STRef var#) val = ST $ \s1# ->-    case writeMutVar# var# val s1#      of { s2# ->-    (# s2#, () #) }---- | Pointer equality.------ @since 2.01-instance Eq (STRef s a) where-    STRef v1# == STRef v2# = isTrue# (sameMutVar# v1# v2#)
− GHC/Show.hs 
@@ -1,614 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, StandaloneDeriving,-             MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}--#include "MachDeps.h"-#if SIZEOF_HSWORD == 4-#define DIGITS       9-#define BASE         1000000000-#elif SIZEOF_HSWORD == 8-#define DIGITS       18-#define BASE         1000000000000000000-#else-#error Please define DIGITS and BASE--- DIGITS should be the largest integer such that---     10^DIGITS < 2^(SIZEOF_HSWORD * 8 - 1)--- BASE should be 10^DIGITS. Note that ^ is not available yet.-#endif---------------------------------------------------------------------------------- |--- Module      :  GHC.Show--- Copyright   :  (c) The University of Glasgow, 1992-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ The 'Show' class, and related operations.-----------------------------------------------------------------------------------module GHC.Show-        (-        Show(..), ShowS,--        -- Instances for Show: (), [], Bool, Ordering, Int, Char--        -- Show support code-        shows, showChar, showString, showMultiLineString,-        showParen, showList__, showCommaSpace, showSpace,-        showLitChar, showLitString, protectEsc,-        intToDigit, showSignedInt,-        appPrec, appPrec1,--        -- Character operations-        asciiTab,-  )-        where--import GHC.Base-import GHC.List ((!!), foldr1, break)-import GHC.Num-import GHC.Stack.Types-import GHC.Tuple (Solo (..))----- | The @shows@ functions return a function that prepends the--- output 'String' to an existing 'String'.  This allows constant-time--- concatenation of results using function composition.-type ShowS = String -> String---- | Conversion of values to readable 'String's.------ Derived instances of 'Show' have the following properties, which--- are compatible with derived instances of 'Text.Read.Read':------ * The result of 'show' is a syntactically correct Haskell---   expression containing only constants, given the fixity---   declarations in force at the point where the type is declared.---   It contains only the constructor names defined in the data type,---   parentheses, and spaces.  When labelled constructor fields are---   used, braces, commas, field names, and equal signs are also used.------ * If the constructor is defined to be an infix operator, then---   'showsPrec' will produce infix applications of the constructor.------ * the representation will be enclosed in parentheses if the---   precedence of the top-level constructor in @x@ is less than @d@---   (associativity is ignored).  Thus, if @d@ is @0@ then the result---   is never surrounded in parentheses; if @d@ is @11@ it is always---   surrounded in parentheses, unless it is an atomic expression.------ * If the constructor is defined using record syntax, then 'show'---   will produce the record-syntax form, with the fields given in the---   same order as the original declaration.------ For example, given the declarations------ > infixr 5 :^:--- > data Tree a =  Leaf a  |  Tree a :^: Tree a------ the derived instance of 'Show' is equivalent to------ > instance (Show a) => Show (Tree a) where--- >--- >        showsPrec d (Leaf m) = showParen (d > app_prec) $--- >             showString "Leaf " . showsPrec (app_prec+1) m--- >          where app_prec = 10--- >--- >        showsPrec d (u :^: v) = showParen (d > up_prec) $--- >             showsPrec (up_prec+1) u .--- >             showString " :^: "      .--- >             showsPrec (up_prec+1) v--- >          where up_prec = 5------ Note that right-associativity of @:^:@ is ignored.  For example,------ * @'show' (Leaf 1 :^: Leaf 2 :^: Leaf 3)@ produces the string---   @\"Leaf 1 :^: (Leaf 2 :^: Leaf 3)\"@.--class  Show a  where-    {-# MINIMAL showsPrec | show #-}--    -- | Convert a value to a readable 'String'.-    ---    -- 'showsPrec' should satisfy the law-    ---    -- > showsPrec d x r ++ s  ==  showsPrec d x (r ++ s)-    ---    -- Derived instances of 'Text.Read.Read' and 'Show' satisfy the following:-    ---    -- * @(x,\"\")@ is an element of-    --   @('Text.Read.readsPrec' d ('showsPrec' d x \"\"))@.-    ---    -- That is, 'Text.Read.readsPrec' parses the string produced by-    -- 'showsPrec', and delivers the value that 'showsPrec' started with.--    showsPrec :: Int    -- ^ the operator precedence of the enclosing-                        -- context (a number from @0@ to @11@).-                        -- Function application has precedence @10@.-              -> a      -- ^ the value to be converted to a 'String'-              -> ShowS--    -- | A specialised variant of 'showsPrec', using precedence context-    -- zero, and returning an ordinary 'String'.-    show      :: a   -> String--    -- | The method 'showList' is provided to allow the programmer to-    -- give a specialised way of showing lists of values.-    -- For example, this is used by the predefined 'Show' instance of-    -- the 'Char' type, where values of type 'String' should be shown-    -- in double quotes, rather than between square brackets.-    showList  :: [a] -> ShowS--    showsPrec _ x s = show x ++ s-    show x          = shows x ""-    showList ls   s = showList__ shows ls s--showList__ :: (a -> ShowS) ->  [a] -> ShowS-showList__ _     []     s = "[]" ++ s-showList__ showx (x:xs) s = '[' : showx x (showl xs)-  where-    showl []     = ']' : s-    showl (y:ys) = ',' : showx y (showl ys)--appPrec, appPrec1 :: Int-        -- Use unboxed stuff because we don't have overloaded numerics yet-appPrec = I# 10#        -- Precedence of application:-                        --   one more than the maximum operator precedence of 9-appPrec1 = I# 11#       -- appPrec + 1------------------------------------------------------------------- Simple Instances------------------------------------------------------------------- | @since 2.01-deriving instance Show ()---- | @since 4.15-deriving instance Show a => Show (Solo a)---- | @since 2.01-instance Show a => Show [a]  where-  {-# SPECIALISE instance Show [String] #-}-  {-# SPECIALISE instance Show [Char] #-}-  {-# SPECIALISE instance Show [Int] #-}-  showsPrec _         = showList---- | @since 2.01-deriving instance Show Bool---- | @since 2.01-deriving instance Show Ordering---- | @since 2.01-instance  Show Char  where-    showsPrec _ '\'' = showString "'\\''"-    showsPrec _ c    = showChar '\'' . showLitChar c . showChar '\''--    showList cs = showChar '"' . showLitString cs . showChar '"'---- | @since 2.01-instance Show Int where-    showsPrec = showSignedInt---- | @since 2.01-instance Show Word where-    showsPrec _ (W# w) = showWord w--showWord :: Word# -> ShowS-showWord w# cs- | isTrue# (w# `ltWord#` 10##) = C# (chr# (ord# '0'# +# word2Int# w#)) : cs- | otherwise = case chr# (ord# '0'# +# word2Int# (w# `remWord#` 10##)) of-               c# ->-                   showWord (w# `quotWord#` 10##) (C# c# : cs)---- | @since 2.01-deriving instance Show a => Show (Maybe a)---- | @since 4.11.0.0-deriving instance Show a => Show (NonEmpty a)---- | @since 2.01-instance Show TyCon where-  showsPrec p (TyCon _ _ _ tc_name _ _) = showsPrec p tc_name---- | @since 4.9.0.0-instance Show TrName where-  showsPrec _ (TrNameS s) = showString (unpackCStringUtf8# s)-  showsPrec _ (TrNameD s) = showString s---- | @since 4.9.0.0-instance Show Module where-  showsPrec _ (Module p m) = shows p . (':' :) . shows m---- | @since 4.9.0.0-instance Show CallStack where-  showsPrec _ = shows . getCallStack---- | @since 4.9.0.0-deriving instance Show SrcLoc------------------------------------------------------------------- Show instances for the first few tuple------------------------------------------------------------------- The explicit 's' parameters are important--- Otherwise GHC thinks that "shows x" might take a lot of work to compute--- and generates defns like---      showsPrec _ (x,y) = let sx = shows x; sy = shows y in---                          \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s))))---- | @since 2.01-instance  (Show a, Show b) => Show (a,b)  where-  showsPrec _ (a,b) s = show_tuple [shows a, shows b] s---- | @since 2.01-instance (Show a, Show b, Show c) => Show (a, b, c) where-  showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where-  showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where-  showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where-  showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)-        => Show (a,b,c,d,e,f,g) where-  showsPrec _ (a,b,c,d,e,f,g) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)-         => Show (a,b,c,d,e,f,g,h) where-  showsPrec _ (a,b,c,d,e,f,g,h) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i)-         => Show (a,b,c,d,e,f,g,h,i) where-  showsPrec _ (a,b,c,d,e,f,g,h,i) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j)-         => Show (a,b,c,d,e,f,g,h,i,j) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i, shows j] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k)-         => Show (a,b,c,d,e,f,g,h,i,j,k) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i, shows j, shows k] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,-          Show l)-         => Show (a,b,c,d,e,f,g,h,i,j,k,l) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i, shows j, shows k, shows l] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,-          Show l, Show m)-         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i, shows j, shows k, shows l, shows m] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,-          Show l, Show m, Show n)-         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i, shows j, shows k, shows l, shows m, shows n] s---- | @since 2.01-instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,-          Show l, Show m, Show n, Show o)-         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where-  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s-        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,-                      shows i, shows j, shows k, shows l, shows m, shows n, shows o] s--show_tuple :: [ShowS] -> ShowS-show_tuple ss = showChar '('-              . foldr1 (\s r -> s . showChar ',' . r) ss-              . showChar ')'------------------------------------------------------------------- Support code for Show------------------------------------------------------------------- | equivalent to 'showsPrec' with a precedence of 0.-shows           :: (Show a) => a -> ShowS-shows           =  showsPrec 0---- | utility function converting a 'Char' to a show function that--- simply prepends the character unchanged.-showChar        :: Char -> ShowS-showChar        =  (:)---- | utility function converting a 'String' to a show function that--- simply prepends the string unchanged.-showString      :: String -> ShowS-showString      =  (++)---- | utility function that surrounds the inner show function with--- parentheses when the 'Bool' parameter is 'True'.-showParen       :: Bool -> ShowS -> ShowS-showParen b p   =  if b then showChar '(' . p . showChar ')' else p--showSpace :: ShowS-showSpace = {-showChar ' '-} \ xs -> ' ' : xs--showCommaSpace :: ShowS-showCommaSpace = showString ", "--- Code specific for characters---- | Convert a character to a string using only printable characters,--- using Haskell source-language escape conventions.  For example:------ > showLitChar '\n' s  =  "\\n" ++ s----showLitChar                :: Char -> ShowS-showLitChar c s | c > '\DEL' =  showChar '\\' (protectEsc isDec (shows (ord c)) s)-showLitChar '\DEL'         s =  showString "\\DEL" s-showLitChar '\\'           s =  showString "\\\\" s-showLitChar c s | c >= ' '   =  showChar c s-showLitChar '\a'           s =  showString "\\a" s-showLitChar '\b'           s =  showString "\\b" s-showLitChar '\f'           s =  showString "\\f" s-showLitChar '\n'           s =  showString "\\n" s-showLitChar '\r'           s =  showString "\\r" s-showLitChar '\t'           s =  showString "\\t" s-showLitChar '\v'           s =  showString "\\v" s-showLitChar '\SO'          s =  protectEsc (== 'H') (showString "\\SO") s-showLitChar c              s =  showString ('\\' : asciiTab!!ord c) s-        -- I've done manual eta-expansion here, because otherwise it's-        -- impossible to stop (asciiTab!!ord) getting floated out as an MFE--showLitString :: String -> ShowS--- | Same as 'showLitChar', but for strings--- It converts the string to a string using Haskell escape conventions--- for non-printable characters. Does not add double-quotes around the--- whole thing; the caller should do that.--- The main difference from showLitChar (apart from the fact that the--- argument is a string not a list) is that we must escape double-quotes-showLitString []         s = s-showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s)-showLitString (c   : cs) s = showLitChar c (showLitString cs s)-   -- Making 's' an explicit parameter makes it clear to GHC that-   -- showLitString has arity 2, which avoids it allocating an extra lambda-   -- The sticking point is the recursive call to (showLitString cs), which-   -- it can't figure out would be ok with arity 2.--showMultiLineString :: String -> [String]--- | Like 'showLitString' (expand escape characters using Haskell--- escape conventions), but---   * break the string into multiple lines---   * wrap the entire thing in double quotes--- Example:  @showMultiLineString "hello\ngoodbye\nblah"@--- returns   @["\"hello\\n\\", "\\goodbye\n\\", "\\blah\""]@-showMultiLineString str-  = go '\"' str-  where-    go ch s = case break (== '\n') s of-                (l, _:s'@(_:_)) -> (ch : showLitString l "\\n\\") : go '\\' s'-                (l, "\n")       -> [ch : showLitString l "\\n\""]-                (l, _)          -> [ch : showLitString l "\""]--isDec :: Char -> Bool-isDec c = c >= '0' && c <= '9'--protectEsc :: (Char -> Bool) -> ShowS -> ShowS-protectEsc p f             = f . cont-                             where cont s@(c:_) | p c = "\\&" ++ s-                                   cont s             = s---asciiTab :: [String]-asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')-           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",-            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",-            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",-            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",-            "SP"]---- Code specific for Ints.---- | Convert an 'Int' in the range @0@..@15@ to the corresponding single--- digit 'Char'.  This function fails on other inputs, and generates--- lower-case hexadecimal digits.-intToDigit :: Int -> Char-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 =  errorWithoutStackTrace ("Char.intToDigit: not a digit " ++ show (I# i))--showSignedInt :: Int -> Int -> ShowS-showSignedInt (I# p) (I# n) r-    | isTrue# (n <# 0#) && isTrue# (p ># 6#) = '(' : itos n (')' : r)-    | otherwise                              = itos n r--itos :: Int# -> String -> String-itos n# cs-    | isTrue# (n# <# 0#) =-        let !(I# minInt#) = minInt in-        if isTrue# (n# ==# minInt#)-                -- negateInt# minInt overflows, so we can't do that:-           then '-' : (case n# `quotRemInt#` 10# of-                       (# q, r #) ->-                           itos' (negateInt# q) (itos' (negateInt# r) cs))-           else '-' : itos' (negateInt# n#) cs-    | otherwise = itos' n# cs-    where-    itos' :: Int# -> String -> String-    itos' x# cs'-        | isTrue# (x# <# 10#) = C# (chr# (ord# '0'# +# x#)) : cs'-        | otherwise = case x# `quotRemInt#` 10# of-                      (# q, r #) ->-                          case chr# (ord# '0'# +# r) of-                          c# ->-                              itos' q (C# c# : cs')------------------------------------------------------------------- The Integer instances for Show------------------------------------------------------------------- | @since 2.01-instance Show Integer where-    showsPrec p (IS i) r = showsPrec p (I# i) r-    showsPrec p n r-        | p > 6 && n < 0 = '(' : integerToString n (')' : r)-        -- Minor point: testing p first gives better code-        -- in the not-uncommon case where the p argument-        -- is a constant-        | otherwise = integerToString n r-    showList = showList__ (showsPrec 0)---- | @since 4.8.0.0-instance Show Natural where-    showsPrec p (NS w) = showsPrec p (W# w)-    showsPrec p n      = showsPrec p (integerFromNatural n)---- Divide and conquer implementation of string conversion-integerToString :: Integer -> String -> String-integerToString n0 cs0-    | n0 < 0    = '-' : integerToString' (- n0) cs0-    | otherwise = integerToString' n0 cs0-    where-    integerToString' :: Integer -> String -> String-    integerToString' n cs-        | n < BASE  = jhead (fromInteger n) cs-        | otherwise = jprinth (jsplitf (BASE*BASE) n) cs--    -- Split n into digits in base p. We first split n into digits-    -- in base p*p and then split each of these digits into two.-    -- Note that the first 'digit' modulo p*p may have a leading zero-    -- in base p that we need to drop - this is what jsplith takes care of.-    -- jsplitb the handles the remaining digits.-    jsplitf :: Integer -> Integer -> [Integer]-    jsplitf p n-        | p > n     = [n]-        | otherwise = jsplith p (jsplitf (p*p) n)--    jsplith :: Integer -> [Integer] -> [Integer]-    jsplith p (n:ns) =-        case n `integerQuotRem#` p of-        (# q, r #) ->-            if q > 0 then q : r : jsplitb p ns-                     else     r : jsplitb p ns-    jsplith _ [] = errorWithoutStackTrace "jsplith: []"--    jsplitb :: Integer -> [Integer] -> [Integer]-    jsplitb _ []     = []-    jsplitb p (n:ns) = case n `integerQuotRem#` p of-                       (# q, r #) ->-                           q : r : jsplitb p ns--    -- Convert a number that has been split into digits in base BASE^2-    -- this includes a last splitting step and then conversion of digits-    -- that all fit into a machine word.-    jprinth :: [Integer] -> String -> String-    jprinth (n:ns) cs =-        case n `integerQuotRem#` BASE of-        (# q', r' #) ->-            let q = fromInteger q'-                r = fromInteger r'-            in if q > 0 then jhead q $ jblock r $ jprintb ns cs-                        else jhead r $ jprintb ns cs-    jprinth [] _ = errorWithoutStackTrace "jprinth []"--    jprintb :: [Integer] -> String -> String-    jprintb []     cs = cs-    jprintb (n:ns) cs = case n `integerQuotRem#` BASE of-                        (# q', r' #) ->-                            let q = fromInteger q'-                                r = fromInteger r'-                            in jblock q $ jblock r $ jprintb ns cs--    -- Convert an integer that fits into a machine word. Again, we have two-    -- functions, one that drops leading zeros (jhead) and one that doesn't-    -- (jblock)-    jhead :: Int -> String -> String-    jhead n cs-        | n < 10    = case unsafeChr (ord '0' + n) of-            c@(C# _) -> c : cs-        | otherwise = case unsafeChr (ord '0' + r) of-            c@(C# _) -> jhead q (c : cs)-        where-        (q, r) = n `quotRemInt` 10--    jblock = jblock' {- ' -} DIGITS--    jblock' :: Int -> Int -> String -> String-    jblock' d n cs-        | d == 1    = case unsafeChr (ord '0' + n) of-             c@(C# _) -> c : cs-        | otherwise = case unsafeChr (ord '0' + r) of-             c@(C# _) -> jblock' (d - 1) q (c : cs)-        where-        (q, r) = n `quotRemInt` 10--instance Show KindRep where-  showsPrec d (KindRepVar v) = showParen (d > 10) $-    showString "KindRepVar " . showsPrec 11 v-  showsPrec d (KindRepTyConApp p q) = showParen (d > 10) $-    showString "KindRepTyConApp "-      . showsPrec 11 p-      . showString " "-      . showsPrec 11 q-  showsPrec d (KindRepApp p q) = showParen (d > 10) $-    showString "KindRepApp "-      . showsPrec 11 p-      . showString " "-      . showsPrec 11 q-  showsPrec d (KindRepFun p q) = showParen (d > 10) $-    showString "KindRepFun "-      . showsPrec 11 p-      . showString " "-      . showsPrec 11 q-  showsPrec d (KindRepTYPE rep) = showParen (d > 10) $-    showString "KindRepTYPE " . showsPrec 11 rep-  showsPrec d (KindRepTypeLitS p q) = showParen (d > 10) $-    showString "KindRepTypeLitS "-      . showsPrec 11 p-      . showString " "-      . showsPrec 11 (unpackCString# q)-  showsPrec d (KindRepTypeLitD p q) = showParen (d > 10) $-    showString "KindRepTypeLitD "-      . showsPrec 11 p-      . showString " "-      . showsPrec 11 q---- | @since 4.15.0.0-deriving instance Show Levity---- | @since 4.11.0.0-deriving instance Show RuntimeRep---- | @since 4.11.0.0-deriving instance Show VecCount---- | @since 4.11.0.0-deriving instance Show VecElem---- | @since 4.11.0.0-deriving instance Show TypeLitSort
− GHC/Stable.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude-           , MagicHash-           , UnboxedTuples-  #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Stable--- Copyright   :  (c) The University of Glasgow, 1992-2004--- License     :  see libraries/base/LICENSE------ Maintainer  :  ffi@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Stable pointers.-----------------------------------------------------------------------------------module GHC.Stable (-        StablePtr(..),-        newStablePtr,-        deRefStablePtr,-        freeStablePtr,-        castStablePtrToPtr,-        castPtrToStablePtr-    ) where--import GHC.Ptr-import GHC.Base--import Unsafe.Coerce ( unsafeCoerceAddr )---------------------------------------------------------------------------------- Stable Pointers--{- |-A /stable pointer/ is a reference to a Haskell expression that is-guaranteed not to be affected by garbage collection, i.e., it will neither be-deallocated nor will the value of the stable pointer itself change during-garbage collection (ordinary references may be relocated during garbage-collection).  Consequently, stable pointers can be passed to foreign code,-which can treat it as an opaque reference to a Haskell value.--A value of type @StablePtr a@ is a stable pointer to a Haskell-expression of type @a@.--}-data {-# CTYPE "HsStablePtr" #-} StablePtr a = StablePtr (StablePtr# a)---- |--- Create a stable pointer referring to the given Haskell value.----newStablePtr   :: a -> IO (StablePtr a)-newStablePtr a = IO $ \ s ->-    case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #)---- |--- Obtain the Haskell value referenced by a stable pointer, i.e., the--- same value that was passed to the corresponding call to--- 'newStablePtr'.  If the argument to 'deRefStablePtr' has--- already been freed using 'freeStablePtr', the behaviour of--- 'deRefStablePtr' is undefined.----deRefStablePtr :: StablePtr a -> IO a-deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s---- |--- Dissolve the association between the stable pointer and the Haskell--- value. Afterwards, if the stable pointer is passed to--- 'deRefStablePtr' or 'freeStablePtr', the behaviour is--- undefined.  However, the stable pointer may still be passed to--- 'castStablePtrToPtr', but the @'Foreign.Ptr.Ptr' ()@ value returned--- by 'castStablePtrToPtr', in this case, is undefined (in particular,--- it may be 'Foreign.Ptr.nullPtr').  Nevertheless, the call--- to 'castStablePtrToPtr' is guaranteed not to diverge.----foreign import ccall unsafe "hs_free_stable_ptr" freeStablePtr :: StablePtr a -> IO ()---- |--- Coerce a stable pointer to an address. No guarantees are made about--- the resulting value, except that the original stable pointer can be--- recovered by 'castPtrToStablePtr'.  In particular, the address may not--- refer to an accessible memory location and any attempt to pass it to--- the member functions of the class 'Foreign.Storable.Storable' leads to--- undefined behaviour.----castStablePtrToPtr :: StablePtr a -> Ptr ()-castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerceAddr s)----- |--- The inverse of 'castStablePtrToPtr', i.e., we have the identity------ > sp == castPtrToStablePtr (castStablePtrToPtr sp)------ for any stable pointer @sp@ on which 'freeStablePtr' has--- not been executed yet.  Moreover, 'castPtrToStablePtr' may--- only be applied to pointers that have been produced by--- 'castStablePtrToPtr'.----castPtrToStablePtr :: Ptr () -> StablePtr a-castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerceAddr a)---- | @since 2.01-instance Eq (StablePtr a) where-    (StablePtr sp1) == (StablePtr sp2) =-        case eqStablePtr# sp1 sp2 of-           0# -> False-           _  -> True
− GHC/StableName.hs 
@@ -1,105 +0,0 @@-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UnboxedTuples #-}---------------------------------------------------------------------------------- |--- Module      :  System.Mem.StableName--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Stable names are a way of performing fast ( \(\mathcal{O}(1)\) ),--- not-quite-exact comparison between objects.------ Stable names solve the following problem: suppose you want to build--- a hash table with Haskell objects as keys, but you want to use--- pointer equality for comparison; maybe because the keys are large--- and hashing would be slow, or perhaps because the keys are infinite--- in size.  We can\'t build a hash table using the address of the--- object as the key, because objects get moved around by the garbage--- collector, meaning a re-hash would be necessary after every garbage--- collection.-------------------------------------------------------------------------------------module GHC.StableName (-  -- * Stable Names-  StableName (..),-  makeStableName,-  hashStableName,-  eqStableName-  ) where--import GHC.IO           ( IO(..) )-import GHC.Base         ( Int(..), StableName#, makeStableName#-                        , eqStableName#, stableNameToInt# )---------------------------------------------------------------------------------- Stable Names--{-|-  An abstract name for an object, that supports equality and hashing.--  Stable names have the following property:--  * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@-   then @sn1@ and @sn2@ were created by calls to @makeStableName@ on-   the same object.--  The reverse is not necessarily true: if two stable names are not-  equal, then the objects they name may still be equal.  Note in particular-  that `makeStableName` may return a different `StableName` after an-  object is evaluated.--  Stable Names are similar to Stable Pointers ("Foreign.StablePtr"),-  but differ in the following ways:--  * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s.-    Stable names are reclaimed by the runtime system when they are no-    longer needed.--  * There is no @deRefStableName@ operation.  You can\'t get back from-    a stable name to the original Haskell object.  The reason for-    this is that the existence of a stable name for an object does not-    guarantee the existence of the object itself; it can still be garbage-    collected.--}--data StableName a = StableName (StableName# a)---- | Makes a 'StableName' for an arbitrary object.  The object passed as--- the first argument is not evaluated by 'makeStableName'.-makeStableName  :: a -> IO (StableName a)-makeStableName a = IO $ \ s ->-    case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #)---- | Convert a 'StableName' to an 'Int'.  The 'Int' returned is not--- necessarily unique; several 'StableName's may map to the same 'Int'--- (in practice however, the chances of this are small, so the result--- of 'hashStableName' makes a good hash key).-hashStableName :: StableName a -> Int-hashStableName (StableName sn) = I# (stableNameToInt# sn)---- | @since 2.01-instance Eq (StableName a) where-    (StableName sn1) == (StableName sn2) =-       case eqStableName# sn1 sn2 of-         0# -> False-         _  -> True---- | Equality on 'StableName' that does not require that the types of--- the arguments match.------ @since 4.7.0.0-eqStableName :: StableName a -> StableName b -> Bool-eqStableName (StableName sn1) (StableName sn2) =-       case eqStableName# sn1 sn2 of-         0# -> False-         _  -> True-  -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to-  -- use it for implementing observable sharing.-
− GHC/Stack.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RankNTypes #-}-{-# 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--------------------------------------------------------------------------------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 =-  case ?callStack of-    EmptyCallStack -> EmptyCallStack-    _              -> 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
− GHC/Stack/CCS.hs-boot 
@@ -1,16 +0,0 @@-{-# 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]
− GHC/Stack/CCS.hsc 
@@ -1,190 +0,0 @@-{-# 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,-    whereFrom,--    -- * 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"---- | A cost-centre stack from GHC's cost-center profiler.-data CostCentreStack---- | A cost-centre from GHC's cost-center profiler.-data CostCentre---- | Returns the current 'CostCentreStack' (value is @nullPtr@ if the current--- program was not compiled with profiling support). Takes a dummy argument--- which can be used to avoid the call to @getCurrentCCS@ being floated out by--- the simplifier, which would result in an uninformative stack ("CAF").-getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)-getCurrentCCS dummy = IO $ \s ->-   case getCurrentCCS## dummy s of-     (## s', addr ##) -> (## s', Ptr addr ##)---- | Get the 'CostCentreStack' associated with the given value.-getCCSOf :: a -> IO (Ptr CostCentreStack)-getCCSOf obj = IO $ \s ->-   case getCCSOf## obj s of-     (## s', addr ##) -> (## s', Ptr addr ##)---- | Run a computation with an empty cost-center stack. For example, this is--- used by the interpreter to run an interpreted computation without the call--- stack showing that it was invoked from GHC.-clearCCS :: IO a -> IO a-clearCCS (IO m) = IO $ \s -> clearCCS## m s---- | Get the 'CostCentre' at the head of a 'CostCentreStack'.-ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)-ccsCC p = (# peek CostCentreStack, cc) p---- | Get the tail of a 'CostCentreStack'.-ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)-ccsParent p = (# peek CostCentreStack, prevStack) p---- | Get the label of a 'CostCentre'.-ccLabel :: Ptr CostCentre -> IO CString-ccLabel p = (# peek CostCentre, label) p---- | Get the module of a 'CostCentre'.-ccModule :: Ptr CostCentre -> IO CString-ccModule p = (# peek CostCentre, module) p---- | Get the source span of a 'CostCentre'.-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 maintained 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 ()---- | Format a 'CostCentreStack' as a list of lines.-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)---- Static Closure Information--data InfoProv-data InfoProvEnt--getIPE :: a -> IO (Ptr InfoProvEnt)-getIPE obj = IO $ \s ->-   case whereFrom## obj s of-     (## s', addr ##) -> (## s', Ptr addr ##)--ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv-ipeProv p = (#ptr InfoProvEnt, prov) p--ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString-ipName p   =  (# peek InfoProv, table_name) p-ipDesc p   =  (# peek InfoProv, closure_desc) p-ipLabel p  =  (# peek InfoProv, label) p-ipModule p =  (# peek InfoProv, module) p-ipSrcLoc p =  (# peek InfoProv, srcloc) p-ipTyDesc p =  (# peek InfoProv, ty_desc) p--infoProvToStrings :: Ptr InfoProv -> IO [String]-infoProvToStrings infop = do-  name <- GHC.peekCString utf8 =<< ipName infop-  desc <- GHC.peekCString utf8 =<< ipDesc infop-  ty_desc <- GHC.peekCString utf8 =<< ipTyDesc infop-  label <- GHC.peekCString utf8 =<< ipLabel infop-  mod <- GHC.peekCString utf8 =<< ipModule infop-  loc <- GHC.peekCString utf8 =<< ipSrcLoc infop-  return [name, desc, ty_desc, label, mod, loc]---- TODO: Add structured output of whereFrom--- | Get information about where a value originated from.--- This information is stored statically in a binary when `-finfo-table-map` is--- enabled.  The source positions will be greatly improved by also enabled debug--- information with `-g3`. Finally you can enable `-fdistinct-constructor-tables` to--- get more precise information about data constructor allocations.------ The information is collect by looking at the info table address of a specific closure and--- then consulting a specially generated map (by `-finfo-table-map`) to find out where we think--- the best source position to describe that info table arose from.-whereFrom :: a -> IO [String]-whereFrom obj = do-  ipe <- getIPE obj-  -- The primop returns the null pointer in two situations at the moment-  -- 1. The lookup fails for whatever reason-  -- 2. -finfo-table-map is not enabled.-  -- It would be good to distinguish between these two cases somehow.-  if ipe == nullPtr-    then return []-    else infoProvToStrings (ipeProv ipe)
− GHC/Stack/Types.hs 
@@ -1,221 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE ImplicitParams    #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds         #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE Trustworthy       #-}--{-# OPTIONS_HADDOCK not-home #-}--- 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 ‘GHC.Base’ (libraries/base/GHC/Base.hs)-          imports ‘GHC.Err’ (libraries/base/GHC/Err.hs)-    which imports ‘GHC.Stack’ (libraries/base/dist-install/build/GHC/Stack.hs)-    which imports ‘GHC.Base‘ (libraries/base/GHC/Base.hs)--}--import GHC.Classes (Eq)-import GHC.Types (Char, Int)---- Make implicit dependency known to build system-import GHC.Tuple ()       -- See Note [Depend on GHC.Tuple] in GHC.Base-import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base---- $setup--- >>> import Prelude--- >>> import GHC.Stack (prettyCallStack, callStack)--------------------------------------------------------------------------- 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------ @--- putStrLnWithCallStack :: HasCallStack => String -> IO ()--- @------ as a variant of @putStrLn@ that will get its call-site and print it,--- along with the string given as argument. We can access the--- call-stack inside @putStrLnWithCallStack@ with 'GHC.Stack.callStack'.------ >>> :{--- putStrLnWithCallStack :: HasCallStack => String -> IO ()--- putStrLnWithCallStack msg = do---   putStrLn msg---   putStrLn (prettyCallStack callStack)--- :}------ Thus, if we call @putStrLnWithCallStack@ we will get a formatted call-stack--- alongside our string.--------- >>> putStrLnWithCallStack "hello"--- hello--- CallStack (from HasCallStack):---   putStrLnWithCallStack, called at <interactive>:... in interactive:Ghci...--------- 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 -- ^ @since 4.9.0.0
− GHC/StaticPtr.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MagicHash                 #-}-{-# LANGUAGE UnboxedTuples             #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--------------------------------------------------------------------------------- |--- Module      :  GHC.StaticPtr--- Copyright   :  (C) 2014 I/O Tweag--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Symbolic references to values.------ References to values are usually implemented with memory addresses, and this--- is practical when communicating values between the different pieces of a--- single process.------ When values are communicated across different processes running in possibly--- different machines, though, addresses are no longer useful since each--- process may use different addresses to store a given value.------ To solve such concern, the references provided by this module offer a key--- that can be used to locate the values on each process. Each process maintains--- a global table of references which can be looked up with a given key. This--- table is known as the Static Pointer Table. The reference can then be--- dereferenced to obtain the value.------ The various communicating processes need to aggree on the keys used to refer--- to the values in the Static Pointer Table, or lookups will fail. Only--- processes launched from the same program binary are guaranteed to use the--- same set of keys.-----------------------------------------------------------------------------------module GHC.StaticPtr-  ( StaticPtr-  , deRefStaticPtr-  , StaticKey-  , staticKey-  , unsafeLookupStaticPtr-  , StaticPtrInfo(..)-  , staticPtrInfo-  , staticPtrKeys-  , IsStatic(..)-  ) where--import Foreign.C.Types     (CInt(..))-import Foreign.Marshal     (allocaArray, peekArray, withArray)-import GHC.Ptr             (Ptr(..), nullPtr)-import GHC.Fingerprint     (Fingerprint(..))-import GHC.Prim-import GHC.Word            (Word64(..))---#include "MachDeps.h"---- | A reference to a value of type @a@.-#if WORD_SIZE_IN_BITS < 64-data StaticPtr a = StaticPtr Word64# Word64# -- The flattened Fingerprint is-                                             -- convenient in the compiler.-                             StaticPtrInfo a-#else-data StaticPtr a = StaticPtr Word# Word#-                             StaticPtrInfo a-#endif--- | Dereferences a static pointer.-deRefStaticPtr :: StaticPtr a -> a-deRefStaticPtr (StaticPtr _ _ _ v) = v---- | A key for 'StaticPtr's that can be serialized and used with--- 'unsafeLookupStaticPtr'.-type StaticKey = Fingerprint---- | The 'StaticKey' that can be used to look up the given 'StaticPtr'.-staticKey :: StaticPtr a -> StaticKey-staticKey (StaticPtr w0 w1 _ _) = Fingerprint (W64# w0) (W64# w1)---- | Looks up a 'StaticPtr' by its 'StaticKey'.------ If the 'StaticPtr' is not found returns @Nothing@.------ This function is unsafe because the program behavior is undefined if the type--- of the returned 'StaticPtr' does not match the expected one.----unsafeLookupStaticPtr :: StaticKey -> IO (Maybe (StaticPtr a))-unsafeLookupStaticPtr (Fingerprint w1 w2) = do-    ptr@(Ptr addr) <- withArray [w1, w2] hs_spt_lookup-    if (ptr == nullPtr)-    then return Nothing-    else case addrToAny# addr of-           (# spe #) -> return (Just spe)--foreign import ccall unsafe hs_spt_lookup :: Ptr Word64 -> IO (Ptr a)---- | A class for things buildable from static pointers.-class IsStatic p where-    fromStaticPtr :: StaticPtr a -> p a---- | @since 4.9.0.0-instance IsStatic StaticPtr where-    fromStaticPtr = id---- | Miscellaneous information available for debugging purposes.-data StaticPtrInfo = StaticPtrInfo-    { -- | Package key of the package where the static pointer is defined-      spInfoUnitId  :: String-      -- | Name of the module where the static pointer is defined-    , spInfoModuleName :: String-      -- | Source location of the definition of the static pointer as a-      -- @(Line, Column)@ pair.-    , spInfoSrcLoc     :: (Int, Int)-    }-  deriving Show -- ^ @since 4.8.0.0---- | 'StaticPtrInfo' of the given 'StaticPtr'.-staticPtrInfo :: StaticPtr a -> StaticPtrInfo-staticPtrInfo (StaticPtr _ _ n _) = n---- | A list of all known keys.-staticPtrKeys :: IO [StaticKey]-staticPtrKeys = do-    keyCount <- hs_spt_key_count-    allocaArray (fromIntegral keyCount) $ \p -> do-      count <- hs_spt_keys p keyCount-      peekArray (fromIntegral count) p >>=-        mapM (\pa -> peekArray 2 pa >>= \[w1, w2] -> return $ Fingerprint w1 w2)-{-# NOINLINE staticPtrKeys #-}--foreign import ccall unsafe hs_spt_key_count :: IO CInt--foreign import ccall unsafe hs_spt_keys :: Ptr a -> CInt -> IO CInt
− GHC/StaticPtr/Internal.hs 
@@ -1,27 +0,0 @@--- |--- Module      :  GHC.StaticPtr--- Copyright   :  (C) 2016 I/O Tweag--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Internal definitions needed for compiling static forms.------- By omitting interface pragmas, we drop the strictness annotations--- which otherwise would bias GHC to conclude that any code using--- the static form would fail.-{-# OPTIONS_GHC -fomit-interface-pragmas #-}-module GHC.StaticPtr.Internal (makeStatic) where--import GHC.StaticPtr(StaticPtr)---- 'makeStatic' should never be called by the user.--- See Note [Grand plan for static forms] in StaticPtrTable.--makeStatic :: (Int, Int) -> a -> StaticPtr a-makeStatic (line, col) _ =-    error $ "GHC bug - makeStatic: Unresolved static form at line "-            ++ show line ++ ", column " ++ show col ++ "."
− GHC/Stats.hsc 
@@ -1,253 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}---------------------------------------------------------------------------------- | This module provides access to internal garbage collection and--- memory usage statistics.  These statistics are not available unless--- a program is run with the @-T@ RTS flag.------ This module is GHC-only and should not be considered portable.------ @since 4.5.0.0-------------------------------------------------------------------------------module GHC.Stats-    (-    -- * Runtime statistics-      RTSStats(..), GCDetails(..), RtsTime-    , getRTSStats-    , getRTSStatsEnabled-) where--import Control.Monad-import Data.Int-import Data.Word-import GHC.Base-import GHC.Generics (Generic)-import GHC.Read ( Read )-import GHC.Show ( Show )-import GHC.IO.Exception-import Foreign.Marshal.Alloc-import Foreign.Storable-import Foreign.Ptr--#include "Rts.h"--foreign import ccall "getRTSStats" getRTSStats_ :: Ptr () -> IO ()---- | Returns whether GC stats have been enabled (with @+RTS -T@, for example).------ @since 4.10.0.0-foreign import ccall "getRTSStatsEnabled" getRTSStatsEnabled :: IO Bool------- | Statistics about runtime activity since the start of the--- program.  This is a mirror of the C @struct RTSStats@ in @RtsAPI.h@------ @since 4.10.0.0----data RTSStats = RTSStats {-  -- ------------------------------------  -- Cumulative stats about memory use--    -- | Total number of GCs-    gcs :: Word32-    -- | Total number of major (oldest generation) GCs-  , major_gcs :: Word32-    -- | Total bytes allocated-  , allocated_bytes :: Word64-    -- | Maximum live data (including large objects + compact regions) in the-    -- heap. Updated after a major GC.-  , max_live_bytes :: Word64-    -- | Maximum live data in large objects-  , max_large_objects_bytes :: Word64-    -- | Maximum live data in compact regions-  , max_compact_bytes :: Word64-    -- | Maximum slop-  , max_slop_bytes :: Word64-    -- | Maximum memory in use by the RTS-  , max_mem_in_use_bytes :: Word64-    -- | Sum of live bytes across all major GCs.  Divided by major_gcs-    -- gives the average live data over the lifetime of the program.-  , cumulative_live_bytes :: Word64-    -- | Sum of copied_bytes across all GCs-  , copied_bytes :: Word64-    -- | Sum of copied_bytes across all parallel GCs-  , par_copied_bytes :: Word64-    -- | Sum of par_max_copied_bytes across all parallel GCs. Deprecated.-  , cumulative_par_max_copied_bytes :: Word64-    -- | Sum of par_balanced_copied bytes across all parallel GCs-  , cumulative_par_balanced_copied_bytes :: Word64--  -- ------------------------------------  -- Cumulative stats about time use-  -- (we use signed values here because due to inaccuracies in timers-  -- the values can occasionally go slightly negative)--    -- | Total CPU time used by the init phase-    -- @since 4.12.0.0-  , init_cpu_ns :: RtsTime-    -- | Total elapsed time used by the init phase-    -- @since 4.12.0.0-  , init_elapsed_ns :: RtsTime-    -- | Total CPU time used by the mutator-  , mutator_cpu_ns :: RtsTime-    -- | Total elapsed time used by the mutator-  , mutator_elapsed_ns :: RtsTime-    -- | Total CPU time used by the GC-  , gc_cpu_ns :: RtsTime-    -- | Total elapsed time used by the GC-  , gc_elapsed_ns :: RtsTime-    -- | Total CPU time (at the previous GC)-  , cpu_ns :: RtsTime-    -- | Total elapsed time (at the previous GC)-  , elapsed_ns :: RtsTime--    -- | The CPU time used during the post-mark pause phase of the concurrent-    -- nonmoving GC.-  , nonmoving_gc_sync_cpu_ns :: RtsTime-    -- | The time elapsed during the post-mark pause phase of the concurrent-    -- nonmoving GC.-  , nonmoving_gc_sync_elapsed_ns :: RtsTime-    -- | The maximum time elapsed during the post-mark pause phase of the-    -- concurrent nonmoving GC.-  , nonmoving_gc_sync_max_elapsed_ns :: RtsTime-    -- | The CPU time used during the post-mark pause phase of the concurrent-    -- nonmoving GC.-  , nonmoving_gc_cpu_ns :: RtsTime-    -- | The time elapsed during the post-mark pause phase of the concurrent-    -- nonmoving GC.-  , nonmoving_gc_elapsed_ns :: RtsTime-    -- | The maximum time elapsed during the post-mark pause phase of the-    -- concurrent nonmoving GC.-  , nonmoving_gc_max_elapsed_ns :: RtsTime--    -- | Details about the most recent GC-  , gc :: GCDetails-  } deriving ( Read -- ^ @since 4.10.0.0-             , Show -- ^ @since 4.10.0.0-             , Generic -- ^ @since 4.15.0.0-             )------- | Statistics about a single GC.  This is a mirror of the C @struct---   GCDetails@ in @RtsAPI.h@, with the field prefixed with @gc_@ to---   avoid collisions with 'RTSStats'.----data GCDetails = GCDetails {-    -- | The generation number of this GC-    gcdetails_gen :: Word32-    -- | Number of threads used in this GC-  , gcdetails_threads :: Word32-    -- | Number of bytes allocated since the previous GC-  , gcdetails_allocated_bytes :: Word64-    -- | Total amount of live data in the heap (incliudes large + compact data).-    -- Updated after every GC. Data in uncollected generations (in minor GCs)-    -- are considered live.-  , gcdetails_live_bytes :: Word64-    -- | Total amount of live data in large objects-  , gcdetails_large_objects_bytes :: Word64-    -- | Total amount of live data in compact regions-  , gcdetails_compact_bytes :: Word64-    -- | Total amount of slop (wasted memory)-  , gcdetails_slop_bytes :: Word64-    -- | Total amount of memory in use by the RTS-  , gcdetails_mem_in_use_bytes :: Word64-    -- | Total amount of data copied during this GC-  , gcdetails_copied_bytes :: Word64-    -- | In parallel GC, the max amount of data copied by any one thread.-    -- Deprecated.-  , gcdetails_par_max_copied_bytes :: Word64-    -- | In parallel GC, the amount of balanced data copied by all threads-  , gcdetails_par_balanced_copied_bytes :: Word64-    -- | The time elapsed during synchronisation before GC-  , gcdetails_sync_elapsed_ns :: RtsTime-    -- | The CPU time used during GC itself-  , gcdetails_cpu_ns :: RtsTime-    -- | The time elapsed during GC itself-  , gcdetails_elapsed_ns :: RtsTime--    -- | The CPU time used during the post-mark pause phase of the concurrent-    -- nonmoving GC.-  , gcdetails_nonmoving_gc_sync_cpu_ns :: RtsTime-    -- | The time elapsed during the post-mark pause phase of the concurrent-    -- nonmoving GC.-  , gcdetails_nonmoving_gc_sync_elapsed_ns :: RtsTime-  } deriving ( Read -- ^ @since 4.10.0.0-             , Show -- ^ @since 4.10.0.0-             , Generic -- ^ @since 4.15.0.0-             )---- | Time values from the RTS, using a fixed resolution of nanoseconds.-type RtsTime = Int64---- | Get current runtime system statistics.------ @since 4.10.0.0----getRTSStats :: IO RTSStats-getRTSStats = do-  statsEnabled <- getRTSStatsEnabled-  unless statsEnabled .  ioError $ IOError-    Nothing-    UnsupportedOperation-    ""-    "GHC.Stats.getRTSStats: GC stats not enabled. Use `+RTS -T -RTS' to enable them."-    Nothing-    Nothing-  allocaBytes (#size RTSStats) $ \p -> do-    getRTSStats_ p-    gcs <- (# peek RTSStats, gcs) p-    major_gcs <- (# peek RTSStats, major_gcs) p-    allocated_bytes <- (# peek RTSStats, allocated_bytes) p-    max_live_bytes <- (# peek RTSStats, max_live_bytes) p-    max_large_objects_bytes <- (# peek RTSStats, max_large_objects_bytes) p-    max_compact_bytes <- (# peek RTSStats, max_compact_bytes) p-    max_slop_bytes <- (# peek RTSStats, max_slop_bytes) p-    max_mem_in_use_bytes <- (# peek RTSStats, max_mem_in_use_bytes) p-    cumulative_live_bytes <- (# peek RTSStats, cumulative_live_bytes) p-    copied_bytes <- (# peek RTSStats, copied_bytes) p-    par_copied_bytes <- (# peek RTSStats, par_copied_bytes) p-    cumulative_par_max_copied_bytes <--      (# peek RTSStats, cumulative_par_max_copied_bytes) p-    cumulative_par_balanced_copied_bytes <--      (# peek RTSStats, cumulative_par_balanced_copied_bytes) p-    init_cpu_ns <- (# peek RTSStats, init_cpu_ns) p-    init_elapsed_ns <- (# peek RTSStats, init_elapsed_ns) p-    mutator_cpu_ns <- (# peek RTSStats, mutator_cpu_ns) p-    mutator_elapsed_ns <- (# peek RTSStats, mutator_elapsed_ns) p-    gc_cpu_ns <- (# peek RTSStats, gc_cpu_ns) p-    gc_elapsed_ns <- (# peek RTSStats, gc_elapsed_ns) p-    cpu_ns <- (# peek RTSStats, cpu_ns) p-    elapsed_ns <- (# peek RTSStats, elapsed_ns) p-    nonmoving_gc_sync_cpu_ns <- (# peek RTSStats, nonmoving_gc_sync_cpu_ns) p-    nonmoving_gc_sync_elapsed_ns <- (# peek RTSStats, nonmoving_gc_sync_elapsed_ns) p-    nonmoving_gc_sync_max_elapsed_ns <- (# peek RTSStats, nonmoving_gc_sync_max_elapsed_ns) p-    nonmoving_gc_cpu_ns <- (# peek RTSStats, nonmoving_gc_cpu_ns) p-    nonmoving_gc_elapsed_ns <- (# peek RTSStats, nonmoving_gc_elapsed_ns) p-    nonmoving_gc_max_elapsed_ns <- (# peek RTSStats, nonmoving_gc_max_elapsed_ns) p-    let pgc = (# ptr RTSStats, gc) p-    gc <- do-      gcdetails_gen <- (# peek GCDetails, gen) pgc-      gcdetails_threads <- (# peek GCDetails, threads) pgc-      gcdetails_allocated_bytes <- (# peek GCDetails, allocated_bytes) pgc-      gcdetails_live_bytes <- (# peek GCDetails, live_bytes) pgc-      gcdetails_large_objects_bytes <--        (# peek GCDetails, large_objects_bytes) pgc-      gcdetails_compact_bytes <- (# peek GCDetails, compact_bytes) pgc-      gcdetails_slop_bytes <- (# peek GCDetails, slop_bytes) pgc-      gcdetails_mem_in_use_bytes <- (# peek GCDetails, mem_in_use_bytes) pgc-      gcdetails_copied_bytes <- (# peek GCDetails, copied_bytes) pgc-      gcdetails_par_max_copied_bytes <--        (# peek GCDetails, par_max_copied_bytes) pgc-      gcdetails_par_balanced_copied_bytes <--        (# peek GCDetails, par_balanced_copied_bytes) pgc-      gcdetails_sync_elapsed_ns <- (# peek GCDetails, sync_elapsed_ns) pgc-      gcdetails_cpu_ns <- (# peek GCDetails, cpu_ns) pgc-      gcdetails_elapsed_ns <- (# peek GCDetails, elapsed_ns) pgc-      gcdetails_nonmoving_gc_sync_cpu_ns <- (# peek GCDetails, nonmoving_gc_sync_cpu_ns) pgc-      gcdetails_nonmoving_gc_sync_elapsed_ns <- (# peek GCDetails, nonmoving_gc_sync_elapsed_ns) pgc-      return GCDetails{..}-    return RTSStats{..}
− GHC/Storable.hs 
@@ -1,158 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Storable--- Copyright   :  (c) The FFI task force, 2000-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  ffi@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Helper functions for "Foreign.Storable"-----------------------------------------------------------------------------------module GHC.Storable-        ( readWideCharOffPtr-        , readIntOffPtr-        , readWordOffPtr-        , readPtrOffPtr-        , readFunPtrOffPtr-        , readFloatOffPtr-        , readDoubleOffPtr-        , readStablePtrOffPtr-        , readInt8OffPtr-        , readInt16OffPtr-        , readInt32OffPtr-        , readInt64OffPtr-        , readWord8OffPtr-        , readWord16OffPtr-        , readWord32OffPtr-        , readWord64OffPtr-        , writeWideCharOffPtr-        , writeIntOffPtr-        , writeWordOffPtr-        , writePtrOffPtr-        , writeFunPtrOffPtr-        , writeFloatOffPtr-        , writeDoubleOffPtr-        , writeStablePtrOffPtr-        , writeInt8OffPtr-        , writeInt16OffPtr-        , writeInt32OffPtr-        , writeInt64OffPtr-        , writeWord8OffPtr-        , writeWord16OffPtr-        , writeWord32OffPtr-        , writeWord64OffPtr-        ) where--import GHC.Stable ( StablePtr(..) )-import GHC.Int-import GHC.Word-import GHC.Ptr-import GHC.Base--readWideCharOffPtr  :: Ptr Char          -> Int -> IO Char-readIntOffPtr       :: Ptr Int           -> Int -> IO Int-readWordOffPtr      :: Ptr Word          -> Int -> IO Word-readPtrOffPtr       :: Ptr (Ptr a)       -> Int -> IO (Ptr a)-readFunPtrOffPtr    :: Ptr (FunPtr a)    -> Int -> IO (FunPtr a)-readFloatOffPtr     :: Ptr Float         -> Int -> IO Float-readDoubleOffPtr    :: Ptr Double        -> Int -> IO Double-readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)-readInt8OffPtr      :: Ptr Int8          -> Int -> IO Int8-readInt16OffPtr     :: Ptr Int16         -> Int -> IO Int16-readInt32OffPtr     :: Ptr Int32         -> Int -> IO Int32-readInt64OffPtr     :: Ptr Int64         -> Int -> IO Int64-readWord8OffPtr     :: Ptr Word8         -> Int -> IO Word8-readWord16OffPtr    :: Ptr Word16        -> Int -> IO Word16-readWord32OffPtr    :: Ptr Word32        -> Int -> IO Word32-readWord64OffPtr    :: Ptr Word64        -> Int -> IO Word64--readWideCharOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readWideCharOffAddr# a i s  of (# s2, x #) -> (# s2, C# x #)-readIntOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readIntOffAddr# a i s       of (# s2, x #) -> (# s2, I# x #)-readWordOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readWordOffAddr# a i s      of (# s2, x #) -> (# s2, W# x #)-readPtrOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, Ptr x #)-readFunPtrOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, FunPtr x #)-readFloatOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readFloatOffAddr# a i s     of (# s2, x #) -> (# s2, F# x #)-readDoubleOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readDoubleOffAddr# a i s    of (# s2, x #) -> (# s2, D# x #)-readStablePtrOffPtr (Ptr a) (I# i)-  = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #)-readInt8OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readInt8OffAddr# a i s      of (# s2, x #) -> (# s2, I8# x #)-readWord8OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readWord8OffAddr# a i s     of (# s2, x #) -> (# s2, W8# x #)-readInt16OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readInt16OffAddr# a i s     of (# s2, x #) -> (# s2, I16# x #)-readWord16OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readWord16OffAddr# a i s    of (# s2, x #) -> (# s2, W16# x #)-readInt32OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readInt32OffAddr# a i s     of (# s2, x #) -> (# s2, I32# x #)-readWord32OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readWord32OffAddr# a i s    of (# s2, x #) -> (# s2, W32# x #)-readInt64OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readInt64OffAddr# a i s     of (# s2, x #) -> (# s2, I64# x #)-readWord64OffPtr (Ptr a) (I# i)-  = IO $ \s -> case readWord64OffAddr# a i s    of (# s2, x #) -> (# s2, W64# x #)--writeWideCharOffPtr  :: Ptr Char          -> Int -> Char        -> IO ()-writeIntOffPtr       :: Ptr Int           -> Int -> Int         -> IO ()-writeWordOffPtr      :: Ptr Word          -> Int -> Word        -> IO ()-writePtrOffPtr       :: Ptr (Ptr a)       -> Int -> Ptr a       -> IO ()-writeFunPtrOffPtr    :: Ptr (FunPtr a)    -> Int -> FunPtr a    -> IO ()-writeFloatOffPtr     :: Ptr Float         -> Int -> Float       -> IO ()-writeDoubleOffPtr    :: Ptr Double        -> Int -> Double      -> IO ()-writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO ()-writeInt8OffPtr      :: Ptr Int8          -> Int -> Int8        -> IO ()-writeInt16OffPtr     :: Ptr Int16         -> Int -> Int16       -> IO ()-writeInt32OffPtr     :: Ptr Int32         -> Int -> Int32       -> IO ()-writeInt64OffPtr     :: Ptr Int64         -> Int -> Int64       -> IO ()-writeWord8OffPtr     :: Ptr Word8         -> Int -> Word8       -> IO ()-writeWord16OffPtr    :: Ptr Word16        -> Int -> Word16      -> IO ()-writeWord32OffPtr    :: Ptr Word32        -> Int -> Word32      -> IO ()-writeWord64OffPtr    :: Ptr Word64        -> Int -> Word64      -> IO ()--writeWideCharOffPtr (Ptr a) (I# i) (C# x)-  = IO $ \s -> case writeWideCharOffAddr# a i x s  of s2 -> (# s2, () #)-writeIntOffPtr (Ptr a) (I# i) (I# x)-  = IO $ \s -> case writeIntOffAddr# a i x s       of s2 -> (# s2, () #)-writeWordOffPtr (Ptr a) (I# i) (W# x)-  = IO $ \s -> case writeWordOffAddr# a i x s      of s2 -> (# s2, () #)-writePtrOffPtr (Ptr a) (I# i) (Ptr x)-  = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)-writeFunPtrOffPtr (Ptr a) (I# i) (FunPtr x)-  = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)-writeFloatOffPtr (Ptr a) (I# i) (F# x)-  = IO $ \s -> case writeFloatOffAddr# a i x s     of s2 -> (# s2, () #)-writeDoubleOffPtr (Ptr a) (I# i) (D# x)-  = IO $ \s -> case writeDoubleOffAddr# a i x s    of s2 -> (# s2, () #)-writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x)-  = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #)-writeInt8OffPtr (Ptr a) (I# i) (I8# x)-  = IO $ \s -> case writeInt8OffAddr# a i x s      of s2 -> (# s2, () #)-writeWord8OffPtr (Ptr a) (I# i) (W8# x)-  = IO $ \s -> case writeWord8OffAddr# a i x s     of s2 -> (# s2, () #)-writeInt16OffPtr (Ptr a) (I# i) (I16# x)-  = IO $ \s -> case writeInt16OffAddr# a i x s     of s2 -> (# s2, () #)-writeWord16OffPtr (Ptr a) (I# i) (W16# x)-  = IO $ \s -> case writeWord16OffAddr# a i x s    of s2 -> (# s2, () #)-writeInt32OffPtr (Ptr a) (I# i) (I32# x)-  = IO $ \s -> case writeInt32OffAddr# a i x s     of s2 -> (# s2, () #)-writeWord32OffPtr (Ptr a) (I# i) (W32# x)-  = IO $ \s -> case writeWord32OffAddr# a i x s    of s2 -> (# s2, () #)-writeInt64OffPtr (Ptr a) (I# i) (I64# x)-  = IO $ \s -> case writeInt64OffAddr# a i x s     of s2 -> (# s2, () #)-writeWord64OffPtr (Ptr a) (I# i) (W64# x)-  = IO $ \s -> case writeWord64OffAddr# a i x s    of s2 -> (# s2, () #)
− GHC/TopHandler.hs 
@@ -1,283 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE UnliftedFFITypes #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.TopHandler--- Copyright   :  (c) The University of Glasgow, 2001-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Support for catching exceptions raised during top-level computations--- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)-----------------------------------------------------------------------------------module GHC.TopHandler (-        runMainIO, runIO, runIOFastExit, runNonIO,-        topHandler, topHandlerFastExit,-        reportStackOverflow, reportError,-        flushStdHandles-    ) where--#include "HsBaseConfig.h"--import Control.Exception-import Data.Maybe--import Foreign-import Foreign.C-import GHC.Base-import GHC.Conc hiding (throwTo)-import GHC.Real-import GHC.IO-import GHC.IO.Handle-import GHC.IO.StdHandles-import GHC.IO.Exception-import GHC.Weak--#if defined(mingw32_HOST_OS)-import GHC.ConsoleHandler-#else-import Data.Dynamic (toDyn)-#endif---- Note [rts_setMainThread must be called unsafely]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ rts_setMainThread must be called as unsafe, because it--- dereferences the Weak# and manipulates the raw Haskell value--- behind it.  Therefore, it must not race with a garbage collection.---- Note [rts_setMainThread has an unsound type]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ 'rts_setMainThread' is imported with type Weak# ThreadId -> IO (),--- but this is an unsound type for it: it grabs the /key/ of the--- 'Weak#' object, which isn't tracked by the type at all.--- That this works at all is a consequence of the fact that--- 'mkWeakThreadId' produces a 'Weak#' with a 'ThreadId#' as the key--- This is fairly robust, in that 'mkWeakThreadId' wouldn't work--- otherwise, but it still is sufficiently non-trivial to justify an--- ASSERT in rts/TopHandler.c.---- see Note [rts_setMainThread must be called unsafely] and--- Note [rts_setMainThread has an unsound type]-foreign import ccall unsafe "rts_setMainThread"-  setMainThread :: Weak# ThreadId -> IO ()---- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is--- called in the program).  It catches otherwise uncaught exceptions,--- and also flushes stdout\/stderr before exiting.-runMainIO :: IO a -> IO a-runMainIO main =-    do-      main_thread_id <- myThreadId-      weak_tid <- mkWeakThreadId main_thread_id-      case weak_tid of (Weak w) -> setMainThread w-      install_interrupt_handler $ do-           m <- deRefWeak weak_tid-           case m of-               Nothing  -> return ()-               Just tid -> throwTo tid (toException UserInterrupt)-      main -- hs_exit() will flush-    `catch`-      topHandler--install_interrupt_handler :: IO () -> IO ()-#if defined(mingw32_HOST_OS)-install_interrupt_handler handler = do-  _ <- GHC.ConsoleHandler.installHandler $-     Catch $ \event ->-        case event of-           ControlC -> handler-           Break    -> handler-           Close    -> handler-           _ -> return ()-  return ()-#else-#include "rts/Signals.h"--- specialised version of System.Posix.Signals.installHandler, which--- isn't available here.-install_interrupt_handler handler = do-   let sig = CONST_SIGINT :: CInt-   _ <- setHandler sig (Just (const handler, toDyn handler))-   _ <- stg_sig_install sig STG_SIG_RST nullPtr-     -- STG_SIG_RST: the second ^C kills us for real, just in case the-     -- RTS or program is unresponsive.-   return ()--foreign import ccall unsafe-  stg_sig_install-        :: CInt                         -- sig no.-        -> CInt                         -- action code (STG_SIG_HAN etc.)-        -> Ptr ()                       -- (in, out) blocked-        -> IO CInt                      -- (ret) old action code-#endif---- | 'runIO' is wrapped around every @foreign export@ and @foreign--- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the--- result of running 'System.Exit.exitWith' in a foreign-exported--- function is the same as in the main thread: it terminates the--- program.----runIO :: IO a -> IO a-runIO main = catch main topHandler---- | Like 'runIO', but in the event of an exception that causes an exit,--- we don't shut down the system cleanly, we just exit.  This is--- useful in some cases, because the safe exit version will give other--- threads a chance to clean up first, which might shut down the--- system in a different way.  For example, try------   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000------ This will sometimes exit with "interrupted" and code 0, because the--- main thread is given a chance to shut down when the child thread calls--- safeExit.  There is a race to shut down between the main and child threads.----runIOFastExit :: IO a -> IO a-runIOFastExit main = catch main topHandlerFastExit-        -- NB. this is used by the testsuite driver---- | The same as 'runIO', but for non-IO computations.  Used for--- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these--- are used to export Haskell functions with non-IO types.----runNonIO :: a -> IO a-runNonIO a = catch (a `seq` return a) topHandler--topHandler :: SomeException -> IO a-topHandler err = catch (real_handler safeExit err) topHandler--topHandlerFastExit :: SomeException -> IO a-topHandlerFastExit err =-  catchException (real_handler fastExit err) topHandlerFastExit---- Make sure we handle errors while reporting the error!--- (e.g. evaluating the string passed to 'error' might generate---  another error, etc.)----real_handler :: (Int -> IO a) -> SomeException -> IO a-real_handler exit se = do-  flushStdHandles -- before any error output-  case fromException se of-      Just StackOverflow -> do-           reportStackOverflow-           exit 2--      Just UserInterrupt -> exitInterrupted--      Just HeapOverflow -> do-           reportHeapOverflow-           exit 251--      _ -> case fromException se of-           -- only the main thread gets ExitException exceptions-           Just ExitSuccess     -> exit 0-           Just (ExitFailure n) -> exit n--           -- EPIPE errors received for stdout are ignored (#2699)-           _ -> catch (case fromException se of-                Just IOError{ ioe_type = ResourceVanished,-                              ioe_errno = Just ioe,-                              ioe_handle = Just hdl }-                   | Errno ioe == ePIPE, hdl == stdout -> exit 0-                _ -> do reportError se-                        exit 1-                ) (disasterHandler exit) -- See Note [Disaster with iconv]---- don't use errorBelch() directly, because we cannot call varargs functions--- using the FFI.-foreign import ccall unsafe "HsBase.h errorBelch2"-   errorBelch :: CString -> CString -> IO ()--disasterHandler :: (Int -> IO a) -> IOError -> IO a-disasterHandler exit _ =-  withCAString "%s" $ \fmt ->-    withCAString msgStr $ \msg ->-      errorBelch fmt msg >> exit 1-  where-    msgStr =-        "encountered an exception while trying to report an exception.\n" ++-        "One possible reason for this is that we failed while trying to " ++-        "encode an error message. Check that your locale is configured " ++-        "properly."--{- Note [Disaster with iconv]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When using iconv, it's possible for things like iconv_open to fail in-restricted environments (like an initram or restricted container), but-when this happens the error raised inevitably calls `peekCString`,-which depends on the users locale, which depends on using-`iconv_open`... which causes an infinite loop.--This occurrence is also known as tickets #10298 and #7695. So to work-around it we just set _another_ error handler and bail directly by-calling the RTS, without iconv at all.--}----- try to flush stdout/stderr, but don't worry if we fail--- (these handles might have errors, and we don't want to go into--- an infinite loop).-flushStdHandles :: IO ()-flushStdHandles = do-  hFlush stdout `catchAny` \_ -> return ()-  hFlush stderr `catchAny` \_ -> return ()--safeExit, fastExit :: Int -> IO a-safeExit = exitHelper useSafeExit-fastExit = exitHelper useFastExit--unreachable :: IO a-unreachable = failIO "If you can read this, shutdownHaskellAndExit did not exit."--exitHelper :: CInt -> Int -> IO a-#if defined(mingw32_HOST_OS)-exitHelper exitKind r =-  shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable-#else--- On Unix we use an encoding for the ExitCode:---      0 -- 255  normal exit code---   -127 -- -1   exit by signal--- For any invalid encoding we just use a replacement (0xff).-exitHelper exitKind r-  | r >= 0 && r <= 255-  = shutdownHaskellAndExit   (fromIntegral   r)  exitKind >> unreachable-  | r >= -127 && r <= -1-  = shutdownHaskellAndSignal (fromIntegral (-r)) exitKind >> unreachable-  | otherwise-  = shutdownHaskellAndExit   0xff                exitKind >> unreachable--foreign import ccall "shutdownHaskellAndSignal"-  shutdownHaskellAndSignal :: CInt -> CInt -> IO ()-#endif--exitInterrupted :: IO a-exitInterrupted =-#if defined(mingw32_HOST_OS)-  safeExit 252-#else-  -- we must exit via the default action for SIGINT, so that the-  -- parent of this process can take appropriate action (see #2301)-  safeExit (-CONST_SIGINT)-#endif---- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*--- re-enter Haskell land through finalizers.-foreign import ccall "Rts.h shutdownHaskellAndExit"-  shutdownHaskellAndExit :: CInt -> CInt -> IO ()--useFastExit, useSafeExit :: CInt-useFastExit = 1-useSafeExit = 0
− GHC/TypeLits.hs 
@@ -1,325 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PolyKinds #-}--{-|-GHC's @DataKinds@ language extension lifts data constructors, natural-numbers, and strings to the type level. This module provides the-primitives needed for working with type-level numbers (the 'Nat' kind),-strings (the 'Symbol' kind), and characters (the 'Char' kind). It also defines the 'TypeError' type-family, a feature that makes use of type-level strings to support user-defined type errors.--For now, this module is the API for working with type-level literals.-However, please note that it is a work in progress and is subject to change.-Once the design of the @DataKinds@ feature is more stable, this will be-considered only an internal GHC module, and the programmer interface for-working with type-level data will be defined in a separate library.--@since 4.6.0.0--}--module GHC.TypeLits-  ( -- * Kinds-    N.Natural, N.Nat, Symbol  -- Symbol is declared in GHC.Types in package ghc-prim--    -- * Linking type and value level-  , N.KnownNat, natVal, natVal'-  , KnownSymbol, symbolVal, symbolVal'-  , KnownChar, charVal, charVal'-  , N.SomeNat(..), SomeSymbol(..), SomeChar(..)-  , someNatVal, someSymbolVal, someCharVal-  , N.sameNat, sameSymbol, sameChar-  , OrderingI(..)-  , N.cmpNat, cmpSymbol, cmpChar---    -- * Functions on type literals-  , type (N.<=), type (N.<=?), type (N.+), type (N.*), type (N.^), type (N.-)-  , type N.Div, type N.Mod, type N.Log2-  , AppendSymbol-  , N.CmpNat, CmpSymbol, CmpChar-  , ConsSymbol, UnconsSymbol-  , CharToNat, NatToChar--  -- * User-defined type errors-  , TypeError-  , ErrorMessage(..)--  ) where--import GHC.Base(Eq(..), Ord(..), Ordering(..), String, otherwise)-import GHC.Types(Symbol, Char)-import GHC.Num(Integer, fromInteger)-import GHC.Show(Show(..))-import GHC.Read(Read(..))-import GHC.Real(toInteger)-import GHC.Prim(magicDict, Proxy#)-import Data.Maybe(Maybe(..))-import Data.Proxy (Proxy(..))-import Data.Type.Equality((:~:)(Refl))-import Data.Type.Ord(OrderingI(..))-import Unsafe.Coerce(unsafeCoerce)--import GHC.TypeLits.Internal(CmpSymbol, CmpChar)-import qualified GHC.TypeNats as N-------------------------------------------------------------------------------------- | This class gives the string associated with a type-level symbol.--- There are instances of the class for every concrete literal: "hello", etc.------ @since 4.7.0.0-class KnownSymbol (n :: Symbol) where-  symbolSing :: SSymbol n---- | @since 4.7.0.0-natVal :: forall n proxy. N.KnownNat n => proxy n -> Integer-natVal p = toInteger (N.natVal p)---- | @since 4.7.0.0-symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String-symbolVal _ = case symbolSing :: SSymbol n of-                SSymbol x -> x---- | @since 4.8.0.0-natVal' :: forall n. N.KnownNat n => Proxy# n -> Integer-natVal' p = toInteger (N.natVal' p)---- | @since 4.8.0.0-symbolVal' :: forall n. KnownSymbol n => Proxy# n -> String-symbolVal' _ = case symbolSing :: SSymbol n of-                SSymbol x -> x----- | This type represents unknown type-level symbols.-data SomeSymbol = forall n. KnownSymbol n => SomeSymbol (Proxy n)-                  -- ^ @since 4.7.0.0---- | @since 4.16.0.0-class KnownChar (n :: Char) where-  charSing :: SChar n--charVal :: forall n proxy. KnownChar n => proxy n -> Char-charVal _ = case charSing :: SChar n of-                 SChar x -> x--charVal' :: forall n. KnownChar n => Proxy# n -> Char-charVal' _ = case charSing :: SChar n of-                SChar x -> x--data SomeChar = forall n. KnownChar n => SomeChar (Proxy n)---- | Convert an integer into an unknown type-level natural.------ @since 4.7.0.0-someNatVal :: Integer -> Maybe N.SomeNat-someNatVal n-  | n >= 0        = Just (N.someNatVal (fromInteger n))-  | otherwise     = Nothing---- | Convert a string into an unknown type-level symbol.------ @since 4.7.0.0-someSymbolVal :: String -> SomeSymbol-someSymbolVal n   = withSSymbol SomeSymbol (SSymbol n) Proxy-{-# NOINLINE someSymbolVal #-}--- For details see Note [NOINLINE someNatVal] in "GHC.TypeNats"--- The issue described there applies to `someSymbolVal` as well.---- | @since 4.7.0.0-instance Eq SomeSymbol where-  SomeSymbol x == SomeSymbol y = symbolVal x == symbolVal y---- | @since 4.7.0.0-instance Ord SomeSymbol where-  compare (SomeSymbol x) (SomeSymbol y) = compare (symbolVal x) (symbolVal y)---- | @since 4.7.0.0-instance Show SomeSymbol where-  showsPrec p (SomeSymbol x) = showsPrec p (symbolVal x)---- | @since 4.7.0.0-instance Read SomeSymbol where-  readsPrec p xs = [ (someSymbolVal a, ys) | (a,ys) <- readsPrec p xs ]----- | Convert a character into an unknown type-level char.------ @since 4.16.0.0-someCharVal :: Char -> SomeChar-someCharVal n   = withSChar SomeChar (SChar n) Proxy-{-# NOINLINE someCharVal #-}--instance Eq SomeChar where-  SomeChar x == SomeChar y = charVal x == charVal y--instance Ord SomeChar where-  compare (SomeChar x) (SomeChar y) = compare (charVal x) (charVal y)--instance Show SomeChar where-  showsPrec p (SomeChar x) = showsPrec p (charVal x)--instance Read SomeChar where-  readsPrec p xs = [ (someCharVal a, ys) | (a,ys) <- readsPrec p xs ]-------------------------------------------------------------------------------------- | Concatenation of type-level symbols.------ @since 4.10.0.0-type family AppendSymbol (m ::Symbol) (n :: Symbol) :: Symbol---- | 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 'Prelude.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-existent 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----- Char-related type families---- | Extending a type-level symbol with a type-level character------ @since 4.16.0.0-type family ConsSymbol (a :: Char) (b :: Symbol) :: Symbol---- | This type family yields type-level `Just` storing the first character--- of a symbol and its tail if it is defined and `Nothing` otherwise.------ @since 4.16.0.0-type family UnconsSymbol (a :: Symbol) :: Maybe (Char, Symbol)---- | Convert a character to its Unicode code point (cf. `Data.Char.ord`)------ @since 4.16.0.0-type family CharToNat (c :: Char) :: N.Nat---- | Convert a Unicode code point to a character (cf. `Data.Char.chr`)------ @since 4.16.0.0-type family NatToChar (n :: N.Nat) :: Char-------------------------------------------------------------------------------------- | We either get evidence that this function was instantiated with the--- same type-level symbols, or 'Nothing'.------ @since 4.7.0.0-sameSymbol :: (KnownSymbol a, KnownSymbol b) =>-              proxy1 a -> proxy2 b -> Maybe (a :~: b)-sameSymbol x y-  | symbolVal x == symbolVal y  = Just (unsafeCoerce Refl)-  | otherwise                   = Nothing----- | We either get evidence that this function was instantiated with the--- same type-level characters, or 'Nothing'.------ @since 4.16.0.0-sameChar :: (KnownChar a, KnownChar b) =>-              proxy1 a -> proxy2 b -> Maybe (a :~: b)-sameChar x y-  | charVal x == charVal y  = Just (unsafeCoerce Refl)-  | otherwise                = Nothing---- | Like 'sameSymbol', but if the symbols aren't equal, this additionally--- provides proof of LT or GT.------ @since 4.16.0.0-cmpSymbol :: forall a b proxy1 proxy2. (KnownSymbol a, KnownSymbol b)-          => proxy1 a -> proxy2 b -> OrderingI a b-cmpSymbol x y = case compare (symbolVal x) (symbolVal y) of-  EQ -> case unsafeCoerce (Refl, Refl) :: (CmpSymbol a b :~: 'EQ, a :~: b) of-    (Refl, Refl) -> EQI-  LT -> case unsafeCoerce Refl :: (CmpSymbol a b :~: 'LT) of-    Refl -> LTI-  GT -> case unsafeCoerce Refl :: (CmpSymbol a b :~: 'GT) of-    Refl -> GTI---- | Like 'sameChar', but if the Chars aren't equal, this additionally--- provides proof of LT or GT.------ @since 4.16.0.0-cmpChar :: forall a b proxy1 proxy2. (KnownChar a, KnownChar b)-        => proxy1 a -> proxy2 b -> OrderingI a b-cmpChar x y = case compare (charVal x) (charVal y) of-  EQ -> case unsafeCoerce (Refl, Refl) :: (CmpChar a b :~: 'EQ, a :~: b) of-    (Refl, Refl) -> EQI-  LT -> case unsafeCoerce Refl :: (CmpChar a b :~: 'LT) of-    Refl -> LTI-  GT -> case unsafeCoerce Refl :: (CmpChar a b :~: 'GT) of-    Refl -> GTI-------------------------------------------------------------------------------------- PRIVATE:--newtype SSymbol (s :: Symbol) = SSymbol String--data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b)---- See Note [magicDictId magic] in "basicType/MkId.hs"-withSSymbol :: (KnownSymbol a => Proxy a -> b)-            -> SSymbol a      -> Proxy a -> b-withSSymbol f x y = magicDict (WrapS f) x y--newtype SChar (s :: Char) = SChar Char--data WrapC a b = WrapC (KnownChar a => Proxy a -> b)---- See Note [q] in "basicType/MkId.hs"-withSChar :: (KnownChar a => Proxy a -> b)-            -> SChar a      -> Proxy a -> b-withSChar f x y = magicDict (WrapC f) x y
− GHC/TypeLits/Internal.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}--{-|-This module exports the Type Literal kinds as well as the comparison type-families for those kinds.  It is needed to prevent module cycles while still-allowing these identifiers to be improted in 'Data.Type.Ord'.--@since 4.16.0.0--}--module GHC.TypeLits.Internal-  ( Symbol-  , CmpSymbol, CmpChar-  ) where--import GHC.Base(Ordering)-import GHC.Types(Symbol, Char)---- | Comparison of type-level symbols, as a function.------ @since 4.7.0.0-type family CmpSymbol (m :: Symbol) (n :: Symbol) :: Ordering---- Char-related type families---- | Comparison of type-level characters.------ @since 4.16.0.0-type family CmpChar (a :: Char) (b :: Char) :: Ordering
− GHC/TypeNats.hs 
@@ -1,251 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoStarIsType #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# 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-for working with type-level naturals should be defined in a separate library.--@since 4.10.0.0--}--module GHC.TypeNats-  ( -- * Nat Kind-    Natural -- declared in GHC.Num.Natural in package ghc-bignum-  , Nat-    -- * Linking type and value level-  , KnownNat, natVal, natVal'-  , SomeNat(..)-  , someNatVal-  , sameNat--    -- * Functions on type literals-  , type (<=), type (<=?), type (+), type (*), type (^), type (-)-  , CmpNat-  , cmpNat-  , Div, Mod, Log2--  ) where--import GHC.Base(Eq(..), Ord(..), otherwise)-import GHC.Types-import GHC.Num.Natural(Natural)-import GHC.Show(Show(..))-import GHC.Read(Read(..))-import GHC.Prim(magicDict, Proxy#)-import Data.Maybe(Maybe(..))-import Data.Proxy (Proxy(..))-import Data.Type.Equality((:~:)(Refl))-import Data.Type.Ord(OrderingI(..), type (<=), type (<=?))-import Unsafe.Coerce(unsafeCoerce)--import GHC.TypeNats.Internal(CmpNat)---- | A type synonym for 'Natural'.------ Prevously, this was an opaque data type, but it was changed to a type--- synonym.------ @since 4.16.0.0--type Nat = Natural------------------------------------------------------------------------------------- | This class gives the integer associated with a type-level natural.--- There are instances of the class for every concrete literal: 0, 1, 2, etc.------ @since 4.7.0.0-class KnownNat (n :: Nat) where-  natSing :: SNat n---- | @since 4.10.0.0-natVal :: forall n proxy. KnownNat n => proxy n -> Natural-natVal _ = case natSing :: SNat n of-             SNat x -> x---- | @since 4.10.0.0-natVal' :: forall n. KnownNat n => Proxy# n -> Natural-natVal' _ = case natSing :: SNat n of-             SNat x -> x---- | This type represents unknown type-level natural numbers.------ @since 4.10.0.0-data SomeNat    = forall n. KnownNat n    => SomeNat    (Proxy n)---- | Convert an integer into an unknown type-level natural.------ @since 4.10.0.0-someNatVal :: Natural -> SomeNat-someNatVal n = withSNat SomeNat (SNat n) Proxy-{-# NOINLINE someNatVal #-} -- See Note [NOINLINE someNatVal]--{- Note [NOINLINE someNatVal]--`someNatVal` converts a natural number to an existentially quantified-dictionary for `KnownNat` (aka `SomeNat`).  The existential quantification-is very important, as it captures the fact that we don't know the type-statically, although we do know that it exists.   Because this type is-fully opaque, we should never be able to prove that it matches anything else.-This is why coherence should still hold:  we can manufacture a `KnownNat k`-dictionary, but it can never be confused with a `KnownNat 33` dictionary,-because we should never be able to prove that `k ~ 33`.--But how to implement `someNatVal`?  We can't quite implement it "honestly"-because `SomeNat` needs to "hide" the type of the newly created dictionary,-but we don't know what the actual type is!  If `someNatVal` was built into-the language, then we could manufacture a new skolem constant,-which should behave correctly.--Since extra language constructors have additional maintenance costs,-we use a trick to implement `someNatVal` in the library.  The idea is that-instead of generating a "fresh" type for each use of `someNatVal`, we simply-use GHC's placeholder type `Any` (of kind `Nat`). So, the elaborated-version of the code is:--  someNatVal n = withSNat @T (SomeNat @T) (SNat @T n) (Proxy @T)-    where type T = Any Nat--After inlining and simplification, this ends up looking something like this:--  someNatVal n = SomeNat @T (KnownNat @T (SNat @T n)) (Proxy @T)-    where type T = Any Nat--`KnownNat` is the constructor for dictionaries for the class `KnownNat`.-See Note [magicDictId magic] in "basicType/MkId.hs" for details on how-we actually construct the dictionary.--Note that using `Any Nat` is not really correct, as multilple calls to-`someNatVal` would violate coherence:--  type T = Any Nat--  x = SomeNat @T (KnownNat @T (SNat @T 1)) (Proxy @T)-  y = SomeNat @T (KnownNat @T (SNat @T 2)) (Proxy @T)--Note that now the code has two dictionaries with the same type, `KnownNat Any`,-but they have different implementations, namely `SNat 1` and `SNat 2`.  This-is not good, as GHC assumes coherence, and it is free to interchange-dictionaries of the same type, but in this case this would produce an incorrect-result.   See #16586 for examples of this happening.--We can avoid this problem by making the definition of `someNatVal` opaque-and we do this by using a `NOINLINE` pragma.  This restores coherence, because-GHC can only inspect the result of `someNatVal` by pattern matching on the-existential, which would generate a new type.  This restores correctness,-at the cost of having a little more allocation for the `SomeNat` constructors.--}------ | @since 4.7.0.0-instance Eq SomeNat where-  SomeNat x == SomeNat y = natVal x == natVal y---- | @since 4.7.0.0-instance Ord SomeNat where-  compare (SomeNat x) (SomeNat y) = compare (natVal x) (natVal y)---- | @since 4.7.0.0-instance Show SomeNat where-  showsPrec p (SomeNat x) = showsPrec p (natVal x)---- | @since 4.7.0.0-instance Read SomeNat where-  readsPrec p xs = do (a,ys) <- readsPrec p xs-                      [(someNatVal a, ys)]------------------------------------------------------------------------------------infixl 6 +, --infixl 7 *, `Div`, `Mod`-infixr 8 ^---- | Addition of type-level naturals.------ @since 4.7.0.0-type family (m :: Nat) + (n :: Nat) :: Nat---- | Multiplication of type-level naturals.------ @since 4.7.0.0-type family (m :: Nat) * (n :: Nat) :: Nat---- | Exponentiation of type-level naturals.------ @since 4.7.0.0-type family (m :: Nat) ^ (n :: Nat) :: Nat---- | Subtraction of type-level naturals.------ @since 4.7.0.0-type family (m :: Nat) - (n :: Nat) :: Nat---- | Division (round down) of natural numbers.--- @Div x 0@ is undefined (i.e., it cannot be reduced).------ @since 4.11.0.0-type family Div (m :: Nat) (n :: Nat) :: Nat---- | Modulus of natural numbers.--- @Mod x 0@ is undefined (i.e., it cannot be reduced).------ @since 4.11.0.0-type family Mod (m :: Nat) (n :: Nat) :: Nat---- | Log base 2 (round down) of natural numbers.--- @Log 0@ is undefined (i.e., it cannot be reduced).------ @since 4.11.0.0-type family Log2 (m :: Nat) :: Nat-------------------------------------------------------------------------------------- | We either get evidence that this function was instantiated with the--- same type-level numbers, or 'Nothing'.------ @since 4.7.0.0-sameNat :: (KnownNat a, KnownNat b) =>-           proxy1 a -> proxy2 b -> Maybe (a :~: b)-sameNat x y-  | natVal x == natVal y = Just (unsafeCoerce Refl)-  | otherwise            = Nothing---- | Like 'sameNat', but if the numbers aren't equal, this additionally--- provides proof of LT or GT.------ @since 4.16.0.0-cmpNat :: forall a b proxy1 proxy2. (KnownNat a, KnownNat b)-       => proxy1 a -> proxy2 b -> OrderingI a b-cmpNat x y = case compare (natVal x) (natVal y) of-  EQ -> case unsafeCoerce (Refl, Refl) :: (CmpNat a b :~: 'EQ, a :~: b) of-    (Refl, Refl) -> EQI-  LT -> case unsafeCoerce Refl :: (CmpNat a b :~: 'LT) of-    Refl -> LTI-  GT -> case unsafeCoerce Refl :: (CmpNat a b :~: 'GT) of-    Refl -> GTI--------------------------------------------------------------------------------------- PRIVATE:--newtype SNat    (n :: Nat)    = SNat    Natural--data WrapN a b = WrapN (KnownNat    a => Proxy a -> b)---- See Note [magicDictId magic] in "basicType/MkId.hs"-withSNat :: (KnownNat a => Proxy a -> b)-         -> SNat a      -> Proxy a -> b-withSNat f x y = magicDict (WrapN f) x y
− GHC/TypeNats/Internal.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_HADDOCK not-home #-}--{-|-This module exports the Type Nat kind as well as the comparison type-family for that kinds.  It is needed to prevent module cycles while still-allowing these identifiers to be improted in 'Data.Type.Ord'.--@since 4.16.0.0--}--module GHC.TypeNats.Internal-  ( Natural-  , CmpNat-  ) where--import GHC.Base(Ordering)-import GHC.Num.Natural(Natural)---- | Comparison of type-level naturals, as a function.------ @since 4.7.0.0-type family CmpNat (m :: Natural) (n :: Natural) :: Ordering
− GHC/Unicode.hs 
@@ -1,415 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Unicode--- Copyright   :  (c) The University of Glasgow, 2003--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC extensions)------ Implementations for the character predicates (isLower, isUpper, etc.)--- and the conversions (toUpper, toLower).  The implementation uses--- libunicode on Unix systems if that is available.-----------------------------------------------------------------------------------module GHC.Unicode (-        unicodeVersion,-        GeneralCategory (..), generalCategory,-        isAscii, isLatin1, isControl,-        isAsciiUpper, isAsciiLower,-        isPrint, isSpace,  isUpper,-        isLower, isAlpha,  isDigit,-        isOctDigit, isHexDigit, isAlphaNum,-        isPunctuation, isSymbol,-        toUpper, toLower, toTitle,-        wgencat-    ) where--import GHC.Base-import GHC.Char        (chr)-import GHC.Real-import GHC.Enum ( Enum (..), Bounded (..) )-import GHC.Ix ( Ix (..) )-import GHC.Num-import {-# SOURCE #-} Data.Version---- Data.Char.chr already imports this and we need to define a Show instance--- for GeneralCategory-import GHC.Show ( Show )---- $setup--- >>> import Prelude--#include "HsBaseConfig.h"-#include "UnicodeVersion.h"---- | Version of Unicode standard used by @base@.-unicodeVersion :: Version-unicodeVersion = makeVersion UNICODE_VERSION_NUMS---- | 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]------ 'Text.Read.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     -- ^ @since 2.01-                 , Eq       -- ^ @since 2.01-                 , Ord      -- ^ @since 2.01-                 , Enum     -- ^ @since 2.01-                 , Bounded  -- ^ @since 2.01-                 , Ix       -- ^ @since 2.01-                 )---- | The Unicode general category of the character. This relies on the--- 'Enum' instance of 'GeneralCategory', which must remain in the--- 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-isAscii c               =  c <  '\x80'---- | Selects the first 256 characters of the Unicode character set,--- corresponding to the ISO 8859-1 (Latin-1) character set.-isLatin1                :: Char -> Bool-isLatin1 c              =  c <= '\xff'---- | Selects ASCII lower-case letters,--- i.e. characters satisfying both 'isAscii' and 'isLower'.-isAsciiLower :: Char -> Bool-isAsciiLower c          =  c >= 'a' && c <= 'z'---- | Selects ASCII upper-case letters,--- i.e. characters satisfying both 'isAscii' and 'isUpper'.-isAsciiUpper :: Char -> Bool-isAsciiUpper c          =  c >= 'A' && c <= 'Z'---- | Selects control characters, which are the non-printing characters of--- the Latin-1 subset of Unicode.-isControl               :: Char -> Bool---- | Selects printable Unicode characters--- (letters, numbers, marks, punctuation, symbols and spaces).-isPrint                 :: Char -> Bool---- | Returns 'True' for any Unicode space character, and the control--- characters @\\t@, @\\n@, @\\r@, @\\f@, @\\v@.-isSpace                 :: Char -> Bool--- isSpace includes non-breaking space--- The magic 0x377 isn't really that magical. As of 2014, all the codepoints--- at or below 0x377 have been assigned, so we shouldn't have to worry about--- any new spaces appearing below there. It would probably be best to--- use branchless ||, but currently the eqLit transformation will undo that,--- so we'll do it like this until there's a way around that.-isSpace c-  | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0-  | otherwise = iswspace (ord c) /= 0-  where-    uc = fromIntegral (ord c) :: Word---- | Selects upper-case or title-case alphabetic Unicode characters (letters).--- Title case is used by a small number of letter ligatures like the--- single-character form of /Lj/.-isUpper                 :: Char -> Bool---- | Selects lower-case alphabetic Unicode characters (letters).-isLower                 :: Char -> Bool---- | Selects alphabetic Unicode characters (lower-case, upper-case and--- title-case letters, plus letters of caseless scripts and modifiers letters).--- This function is equivalent to 'Data.Char.isLetter'.-isAlpha                 :: Char -> Bool---- | Selects alphabetic or numeric Unicode characters.------ Note that numeric digits outside the ASCII range, as well as numeric--- characters which aren't digits, are selected by this function but not by--- 'isDigit'. Such characters may be part of identifiers but are not used by--- the printer and reader to represent numbers.-isAlphaNum              :: Char -> Bool---- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@.-isDigit                 :: Char -> Bool-isDigit c               =  (fromIntegral (ord c - ord '0') :: Word) <= 9---- We use an addition and an unsigned comparison instead of two signed--- comparisons because it's usually faster and puts less strain on branch--- prediction. It likely also enables some CSE when combined with functions--- that follow up with an actual conversion.---- | Selects ASCII octal digits, i.e. @\'0\'@..@\'7\'@.-isOctDigit              :: Char -> Bool-isOctDigit c            =  (fromIntegral (ord c - ord '0') :: Word) <= 7---- | Selects ASCII hexadecimal digits,--- i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@.-isHexDigit              :: Char -> Bool-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--- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,--- 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--- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,--- 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.-toUpper                 :: Char -> Char---- | Convert a letter to the corresponding lower-case letter, if any.--- Any other character is returned unchanged.-toLower                 :: Char -> Char---- | Convert a letter to the corresponding title-case or upper-case--- letter, if any.  (Title case differs from upper case only for a small--- number of ligature letters.)--- Any other character is returned unchanged.-toTitle                 :: Char -> Char---- -------------------------------------------------------------------------------- Implementation with the supplied auto-generated Unicode character properties--- table---- Regardless of the O/S and Library, use the functions contained in WCsubst.c--isAlpha    c = iswalpha (ord c) /= 0-isAlphaNum c = iswalnum (ord c) /= 0-isControl  c = iswcntrl (ord c) /= 0-isPrint    c = iswprint (ord c) /= 0-isUpper    c = iswupper (ord c) /= 0-isLower    c = iswlower (ord c) /= 0--toLower c = chr (towlower (ord c))-toUpper c = chr (towupper (ord c))-toTitle c = chr (towtitle (ord c))--foreign import ccall unsafe "u_iswalpha"-  iswalpha :: Int -> Int--foreign import ccall unsafe "u_iswalnum"-  iswalnum :: Int -> Int--foreign import ccall unsafe "u_iswcntrl"-  iswcntrl :: Int -> Int--foreign import ccall unsafe "u_iswspace"-  iswspace :: Int -> Int--foreign import ccall unsafe "u_iswprint"-  iswprint :: Int -> Int--foreign import ccall unsafe "u_iswlower"-  iswlower :: Int -> Int--foreign import ccall unsafe "u_iswupper"-  iswupper :: Int -> Int--foreign import ccall unsafe "u_towlower"-  towlower :: Int -> Int--foreign import ccall unsafe "u_towupper"-  towupper :: Int -> Int--foreign import ccall unsafe "u_towtitle"-  towtitle :: Int -> Int--foreign import ccall unsafe "u_gencat"-  wgencat :: Int -> Int
− GHC/Weak.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Weak--- Copyright   :  (c) The University of Glasgow, 1998-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Weak pointers.-----------------------------------------------------------------------------------module GHC.Weak (-        Weak(..),-        mkWeak,-        deRefWeak,-        finalize,-        runFinalizerBatch-    ) where--import GHC.Base--{-|-A weak pointer object with a key and a value.  The value has type @v@.--A weak pointer expresses a relationship between two objects, the-/key/ and the /value/:  if the key is considered to be alive by the-garbage collector, then the value is also alive.  A reference from-the value to the key does /not/ keep the key alive.--A weak pointer may also have a finalizer of type @IO ()@; if it does,-then the finalizer will be run at most once, at a time after the key-has become unreachable by the program (\"dead\").  The storage manager-attempts to run the finalizer(s) for an object soon after the object-dies, but promptness is not guaranteed.--It is not guaranteed that a finalizer will eventually run, and no-attempt is made to run outstanding finalizers when the program exits.-Therefore finalizers should not be relied on to clean up resources --other methods (eg. exception handlers) should be employed, possibly in-addition to finalizers.--References from the finalizer to the key are treated in the same way-as references from the value to the key: they do not keep the key-alive.  A finalizer may therefore ressurrect the key, perhaps by-storing it in the same data structure.--The finalizer, and the relationship between the key and the value,-exist regardless of whether the program keeps a reference to the-'Weak' object or not.--There may be multiple weak pointers with the same key.  In this-case, the finalizers for each of these weak pointers will all be-run in some arbitrary order, or perhaps concurrently, when the key-dies.  If the programmer specifies a finalizer that assumes it has-the only reference to an object (for example, a file that it wishes-to close), then the programmer must ensure that there is only one-such finalizer.--If there are no other threads to run, the runtime system will check-for runnable finalizers before declaring the system to be deadlocked.--WARNING: weak pointers to ordinary non-primitive Haskell types are-particularly fragile, because the compiler is free to optimise away or-duplicate the underlying data structure.  Therefore attempting to-place a finalizer on an ordinary Haskell type may well result in the-finalizer running earlier than you expected.  This is not a problem-for caches and memo tables where early finalization is benign.--Finalizers /can/ be used reliably for types that are created explicitly-and have identity, such as @IORef@ and @MVar@.  However, to place a-finalizer on one of these types, you should use the specific operation-provided for that type, e.g. @mkWeakIORef@ and @addMVarFinalizer@-respectively (the non-uniformity is accidental).  These operations-attach the finalizer to the primitive object inside the box-(e.g. @MutVar#@ in the case of @IORef@), because attaching the-finalizer to the box itself fails when the outer box is optimised away-by the compiler.---}-data Weak v = Weak (Weak# v)---- | Establishes a weak pointer to @k@, with value @v@ and a finalizer.------ This is the most general interface for building a weak pointer.----mkWeak  :: k                            -- ^ key-        -> v                            -- ^ value-        -> Maybe (IO ())                -- ^ finalizer-        -> IO (Weak v)                  -- ^ returns: a weak pointer object--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 #) }--{-|-Dereferences a weak pointer.  If the key is still alive, then-@'Just' v@ is returned (where @v@ is the /value/ in the weak pointer), otherwise-'Nothing' is returned.--The return value of 'deRefWeak' depends on when the garbage collector-runs, hence it is in the 'IO' monad.--}-deRefWeak :: Weak v -> IO (Maybe v)-deRefWeak (Weak w) = IO $ \s ->-   case deRefWeak# w s of-        (# s1, flag, p #) -> case flag of-                                0# -> (# s1, Nothing #)-                                _  -> (# s1, Just p #)---- | Causes a the finalizer associated with a weak pointer to be run--- immediately.-finalize :: Weak v -> IO ()-finalize (Weak w) = IO $ \s ->-   case finalizeWeak# w s of-        (# s1, 0#, _ #) -> (# s1, () #) -- already dead, or no finalizer-        (# s1, _,  f #) -> f s1--{--Instance Eq (Weak v) where-  (Weak w1) == (Weak w2) = w1 `sameWeak#` w2--}----- run a batch of finalizers from the garbage collector.  We're given--- an array of finalizers and the length of the array, and we just--- call each one in turn.------ the IO primitives are inlined by hand here to get the optimal--- code (sigh) --SDM.--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 catch# (\p -> (# io p, () #))-                                    (\_ s'' -> (# s'', () #)) s of          {-                         (# s', _ #) -> unIO (go m') s'-                        }}-   in-        go n
− GHC/Windows.hs 
@@ -1,238 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Windows--- Copyright   :  (c) The University of Glasgow, 2009--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  internal--- Portability :  non-portable------ Windows functionality used by several modules.------ ToDo: this just duplicates part of System.Win32.Types, which isn't--- available yet.  We should move some Win32 functionality down here,--- maybe as part of the grand reorganisation of the base package...-----------------------------------------------------------------------------------module GHC.Windows (-        -- * Types-        BOOL,-        LPBOOL,-        BYTE,-        DWORD,-        DDWORD,-        UINT,-        ULONG,-        ErrCode,-        HANDLE,-        LPWSTR,-        LPTSTR,-        LPCTSTR,-        LPVOID,-        LPDWORD,-        LPSTR,-        LPCSTR,-        LPCWSTR,-        WORD,-        UCHAR,-        NTSTATUS,--        -- * Constants-        iNFINITE,-        iNVALID_HANDLE_VALUE,--        -- * System errors-        throwGetLastError,-        failWith,-        getLastError,-        getErrorMessage,-        errCodeToIOError,--        -- ** Guards for system calls that might fail-        failIf,-        failIf_,-        failIfNull,-        failIfZero,-        failIfFalse_,-        failUnlessSuccess,-        failUnlessSuccessOr,--        -- ** Mapping system errors to errno-        -- $errno-        c_maperrno,-        c_maperrno_func,--        -- * Misc-        ddwordToDwords,-        dwordsToDdword,-        nullHANDLE,-    ) where--import Data.Bits (finiteBitSize, shiftL, shiftR, (.|.), (.&.))-import Data.Char-import Data.OldList-import Data.Maybe-import Data.Word-import Data.Int-import Foreign.C.Error-import Foreign.C.String-import Foreign.C.Types-import Foreign.Ptr-import GHC.Base-import GHC.Enum (maxBound)-import GHC.IO-import GHC.Num-import GHC.Real (fromIntegral)-import System.IO.Error--import qualified Numeric--#include "windows_cconv.h"--type BOOL     = Bool-type LPBOOL   = Ptr BOOL-type BYTE     = Word8-type DWORD    = Word32-type UINT     = Word32-type ULONG    = Word32-type ErrCode  = DWORD-type HANDLE   = Ptr ()-type LPWSTR   = Ptr CWchar-type LPCTSTR  = LPTSTR-type LPVOID   = Ptr ()-type LPDWORD  = Ptr DWORD-type LPSTR    = Ptr CChar-type LPCSTR   = LPSTR-type LPCWSTR  = LPWSTR-type WORD     = Word16-type UCHAR    = Word8-type NTSTATUS = Int32--nullHANDLE :: HANDLE-nullHANDLE = nullPtr---- Not really a basic type, but used in many places-type DDWORD        = Word64---- | Be careful with this.  LPTSTR can mean either WCHAR* or CHAR*, depending--- on whether the UNICODE macro is defined in the corresponding C code.--- Consider using LPWSTR instead.-type LPTSTR = LPWSTR--iNFINITE :: DWORD-iNFINITE = 0xFFFFFFFF -- urgh--iNVALID_HANDLE_VALUE :: HANDLE-iNVALID_HANDLE_VALUE = wordPtrToPtr (-1)---- | Get the last system error, and throw it as an 'IOError' exception.-throwGetLastError :: String -> IO a-throwGetLastError where_from =-    getLastError >>= failWith where_from---- | Convert a Windows error code to an exception, then throw it.-failWith :: String -> ErrCode -> IO a-failWith fn_name err_code =-    errCodeToIOError fn_name err_code >>= throwIO---- | Convert a Windows error code to an exception.-errCodeToIOError :: String -> ErrCode -> IO IOError-errCodeToIOError fn_name err_code = do-    msg <- getErrorMessage err_code--    -- turn GetLastError() into errno, which errnoToIOError knows-    -- how to convert to an IOException we can throw.-    -- XXX we should really do this directly.-    let errno = c_maperrno_func err_code--    let msg' = dropWhileEnd isSpace msg -- drop trailing \n-        ioerror = errnoToIOError fn_name errno Nothing Nothing-                    `ioeSetErrorString` msg'-    return ioerror---- | Get a string describing a Windows error code.  This uses the--- @FormatMessage@ system call.-getErrorMessage :: ErrCode -> IO String-getErrorMessage err_code =-    mask_ $ do-        c_msg <- c_getErrorMessage err_code-        if c_msg == nullPtr-          then return $ "Error 0x" ++ Numeric.showHex err_code ""-          else do msg <- peekCWString c_msg-                  -- We ignore failure of freeing c_msg, given we're already failing-                  _ <- localFree c_msg-                  return msg--failIf :: (a -> Bool) -> String -> IO a -> IO a-failIf p wh act = do-    v <- act-    if p v then throwGetLastError wh else return v--failIf_ :: (a -> Bool) -> String -> IO a -> IO ()-failIf_ p wh act = do-    v <- act-    if p v then throwGetLastError wh else return ()--failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)-failIfNull = failIf (== nullPtr)--failIfZero :: (Eq a, Num a) => String -> IO a -> IO a-failIfZero = failIf (== 0)--failIfFalse_ :: String -> IO Bool -> IO ()-failIfFalse_ = failIf_ not--failUnlessSuccess :: String -> IO ErrCode -> IO ()-failUnlessSuccess fn_name act = do-    r <- act-    if r == 0 then return () else failWith fn_name r--failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool-failUnlessSuccessOr val fn_name act = do-    r <- act-    if r == 0 then return False-        else if r == val then return True-        else failWith fn_name r---- $errno------ On Windows, @errno@ is defined by msvcrt.dll for compatibility with other--- systems, and is distinct from the system error as returned--- by @GetLastError@.---- | Map the last system error to an errno value, and assign it to @errno@.-foreign import ccall unsafe "maperrno"             -- in Win32Utils.c-   c_maperrno :: IO ()---- | Pure function variant of 'c_maperrno' that does not call @GetLastError@--- or modify @errno@.-foreign import ccall unsafe "maperrno_func"        -- in Win32Utils.c-   c_maperrno_func :: ErrCode -> Errno--foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c-    c_getErrorMessage :: DWORD -> IO LPWSTR--foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"-    localFree :: Ptr a -> IO (Ptr a)---- | Get the last system error produced in the current thread.-foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"-    getLastError :: IO ErrCode--------------------------------------------------------------------- Misc helpers-------------------------------------------------------------------ddwordToDwords :: DDWORD -> (DWORD,DWORD)-ddwordToDwords n =-        (fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD))-        ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))--dwordsToDdword:: (DWORD,DWORD) -> DDWORD-dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi)
− GHC/Word.hs 
@@ -1,1058 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, UnboxedTuples #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.Word--- Copyright   :  (c) The University of Glasgow, 1997-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (GHC Extensions)------ Sized unsigned integral types: 'Word', 'Word8', 'Word16', 'Word32', and--- 'Word64'.-----------------------------------------------------------------------------------#include "MachDeps.h"--module GHC.Word (-    Word(..), Word8(..), Word16(..), Word32(..), Word64(..),--    -- * Shifts-    uncheckedShiftL64#,-    uncheckedShiftRL64#,--    -- * Byte swapping-    byteSwap16,-    byteSwap32,-    byteSwap64,--    -- * Bit reversal-    bitReverse8,-    bitReverse16,-    bitReverse32,-    bitReverse64,--    -- * 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.Maybe--#if WORD_SIZE_IN_BITS < 64-import GHC.Prim-#endif--import GHC.Base-import GHC.Bits-import GHC.Enum-import GHC.Num-import GHC.Real-import GHC.Ix-import GHC.Show----------------------------------------------------------------------------- type Word8----------------------------------------------------------------------------- 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# Word8#----- ^ 8-bit unsigned integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Word8 where-    (==) = eqWord8-    (/=) = neWord8--eqWord8, neWord8 :: Word8 -> Word8 -> Bool-eqWord8 (W8# x) (W8# y) = isTrue# ((word8ToWord# x) `eqWord#` (word8ToWord# y))-neWord8 (W8# x) (W8# y) = isTrue# ((word8ToWord# x) `neWord#` (word8ToWord# y))-{-# INLINE [1] eqWord8 #-}-{-# INLINE [1] neWord8 #-}---- | @since 2.01-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 `gtWord8#` y)-(W8# x) `geWord8` (W8# y) = isTrue# (x `geWord8#` y)-(W8# x) `ltWord8` (W8# y) = isTrue# (x `ltWord8#` y)-(W8# x) `leWord8` (W8# y) = isTrue# (x `leWord8#` y)---- | @since 2.01-instance Show Word8 where-    showsPrec p x = showsPrec p (fromIntegral x :: Int)---- | @since 2.01-instance Num Word8 where-    (W8# x#) + (W8# y#)    = W8# (wordToWord8# ((word8ToWord# x#) `plusWord#` (word8ToWord# y#)))-    (W8# x#) - (W8# y#)    = W8# (wordToWord8# ((word8ToWord# x#) `minusWord#` (word8ToWord# y#)))-    (W8# x#) * (W8# y#)    = W8# (wordToWord8# ((word8ToWord# x#) `timesWord#` (word8ToWord# y#)))-    negate (W8# x#)        = W8# (wordToWord8# (int2Word# (negateInt# (word2Int# ((word8ToWord# x#))))))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W8# (wordToWord8# (integerToWord# i))---- | @since 2.01-instance Real Word8 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Enum Word8 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word8"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word8"-    toEnum i@(I# i#)-        | i >= 0 && i <= fromIntegral (maxBound::Word8)-                        = W8# (wordToWord8# (int2Word# i#))-        | otherwise     = toEnumError "Word8" i (minBound::Word8, maxBound::Word8)-    fromEnum (W8# x#)   = I# (word2Int# (word8ToWord# x#))-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen---- | @since 2.01-instance Integral Word8 where-    quot    (W8# x#) y@(W8# y#)-        | y /= 0                  = W8# (wordToWord8# ((word8ToWord# x#) `quotWord#` (word8ToWord# y#)))-        | otherwise               = divZeroError-    rem     (W8# x#) y@(W8# y#)-        | y /= 0                  = W8# (wordToWord8# ((word8ToWord# x#) `remWord#` (word8ToWord# y#)))-        | otherwise               = divZeroError-    div     (W8# x#) y@(W8# y#)-        | y /= 0                  = W8# (wordToWord8# ((word8ToWord# x#) `quotWord#` (word8ToWord# y#)))-        | otherwise               = divZeroError-    mod     (W8# x#) y@(W8# y#)-        | y /= 0                  = W8# (wordToWord8# ((word8ToWord# x#) `remWord#` (word8ToWord# y#)))-        | otherwise               = divZeroError-    quotRem (W8# x#) y@(W8# y#)-        | y /= 0                  = case (word8ToWord# x#) `quotRemWord#` (word8ToWord# y#) of-                                    (# q, r #) ->-                                        (W8# (wordToWord8# q), W8# (wordToWord8# r))-        | otherwise               = divZeroError-    divMod  (W8# x#) y@(W8# y#)-        | y /= 0                  = (W8# (wordToWord8# ((word8ToWord# x#) `quotWord#` (word8ToWord# y#)))-                                    ,W8# (wordToWord8# ((word8ToWord# x#) `remWord#` (word8ToWord# y#))))-        | otherwise               = divZeroError-    toInteger (W8# x#)            = IS (word2Int# (word8ToWord# x#))---- | @since 2.01-instance Bounded Word8 where-    minBound = 0-    maxBound = 0xFF---- | @since 2.01-instance Ix Word8 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral (i - m)-    inRange (m,n) i     = m <= i && i <= n---- | @since 2.01-instance Bits Word8 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (W8# x#) .&.   (W8# y#)   = W8# (wordToWord8# ((word8ToWord# x#) `and#` (word8ToWord# y#)))-    (W8# x#) .|.   (W8# y#)   = W8# (wordToWord8# ((word8ToWord# x#) `or#`  (word8ToWord# y#)))-    (W8# x#) `xor` (W8# y#)   = W8# (wordToWord8# ((word8ToWord# x#) `xor#` (word8ToWord# y#)))-    complement (W8# x#)       = W8# (wordToWord8# (not# (word8ToWord# x#)))-    (W8# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#) = W8# (wordToWord8# ((word8ToWord# x#) `shiftL#` i#))-        | otherwise           = W8# (wordToWord8# ((word8ToWord# x#) `shiftRL#` negateInt# i#))-    (W8# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#) = W8# (wordToWord8# ((word8ToWord# x#) `shiftL#` i#))-        | otherwise           = overflowError-    (W8# x#) `unsafeShiftL` (I# i#) =-        W8# (wordToWord8# ((word8ToWord# x#) `uncheckedShiftL#` i#))-    (W8# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#) = W8# (wordToWord8# ((word8ToWord# x#) `shiftRL#` i#))-        | otherwise           = overflowError-    (W8# x#) `unsafeShiftR` (I# i#) = W8# (wordToWord8# ((word8ToWord# x#) `uncheckedShiftRL#` i#))-    (W8# x#) `rotate`       (I# i#)-        | isTrue# (i'# ==# 0#) = W8# x#-        | otherwise  = W8# (wordToWord8# (((word8ToWord# x#) `uncheckedShiftL#` i'#) `or#`-                                          ((word8ToWord# x#) `uncheckedShiftRL#` (8# -# i'#))))-        where-        !i'# = word2Int# (int2Word# i# `and#` 7##)-    bitSizeMaybe i            = Just (finiteBitSize i)-    bitSize i                 = finiteBitSize i-    isSigned _                = False-    popCount (W8# x#)         = I# (word2Int# (popCnt8# (word8ToWord# x#)))-    bit                       = bitDefault-    testBit                   = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Word8 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 8-    countLeadingZeros  (W8# x#) = I# (word2Int# (clz8# (word8ToWord# x#)))-    countTrailingZeros (W8# x#) = I# (word2Int# (ctz8# (word8ToWord# x#)))--{-# RULES-"properFraction/Float->(Word8,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Word8) n, y :: Float) }-"truncate/Float->Word8"-    truncate = (fromIntegral :: Int -> Word8) . (truncate :: Float -> Int)-"floor/Float->Word8"-    floor    = (fromIntegral :: Int -> Word8) . (floor :: Float -> Int)-"ceiling/Float->Word8"-    ceiling  = (fromIntegral :: Int -> Word8) . (ceiling :: Float -> Int)-"round/Float->Word8"-    round    = (fromIntegral :: Int -> Word8) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Word8,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Word8) n, y :: Double) }-"truncate/Double->Word8"-    truncate = (fromIntegral :: Int -> Word8) . (truncate :: Double -> Int)-"floor/Double->Word8"-    floor    = (fromIntegral :: Int -> Word8) . (floor :: Double -> Int)-"ceiling/Double->Word8"-    ceiling  = (fromIntegral :: Int -> Word8) . (ceiling :: Double -> Int)-"round/Double->Word8"-    round    = (fromIntegral :: Int -> Word8) . (round  :: Double -> Int)-  #-}----------------------------------------------------------------------------- type Word16----------------------------------------------------------------------------- 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# Word16#--- ^ 16-bit unsigned integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Word16 where-    (==) = eqWord16-    (/=) = neWord16--eqWord16, neWord16 :: Word16 -> Word16 -> Bool-eqWord16 (W16# x) (W16# y) = isTrue# ((word16ToWord# x) `eqWord#` (word16ToWord# y))-neWord16 (W16# x) (W16# y) = isTrue# ((word16ToWord# x) `neWord#` (word16ToWord# y))-{-# INLINE [1] eqWord16 #-}-{-# INLINE [1] neWord16 #-}---- | @since 2.01-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 `gtWord16#` y)-(W16# x) `geWord16` (W16# y) = isTrue# (x `geWord16#` y)-(W16# x) `ltWord16` (W16# y) = isTrue# (x `ltWord16#` y)-(W16# x) `leWord16` (W16# y) = isTrue# (x `leWord16#` y)---- | @since 2.01-instance Show Word16 where-    showsPrec p x = showsPrec p (fromIntegral x :: Int)---- | @since 2.01-instance Num Word16 where-    (W16# x#) + (W16# y#)  = W16# (wordToWord16# ((word16ToWord# x#) `plusWord#` (word16ToWord# y#)))-    (W16# x#) - (W16# y#)  = W16# (wordToWord16# ((word16ToWord# x#) `minusWord#` (word16ToWord# y#)))-    (W16# x#) * (W16# y#)  = W16# (wordToWord16# ((word16ToWord# x#) `timesWord#` (word16ToWord# y#)))-    negate (W16# x#)       = W16# (wordToWord16# (int2Word# (negateInt# (word2Int# (word16ToWord# x#)))))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W16# (wordToWord16# (integerToWord# i))---- | @since 2.01-instance Real Word16 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Enum Word16 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word16"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word16"-    toEnum i@(I# i#)-        | i >= 0 && i <= fromIntegral (maxBound::Word16)-                        = W16# (wordToWord16# (int2Word# i#))-        | otherwise     = toEnumError "Word16" i (minBound::Word16, maxBound::Word16)-    fromEnum (W16# x#)  = I# (word2Int# (word16ToWord# x#))-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen---- | @since 2.01-instance Integral Word16 where-    quot    (W16# x#) y@(W16# y#)-        | y /= 0                    = W16# (wordToWord16# ((word16ToWord# x#) `quotWord#` (word16ToWord# y#)))-        | otherwise                 = divZeroError-    rem     (W16# x#) y@(W16# y#)-        | y /= 0                    = W16# (wordToWord16# ((word16ToWord# x#) `remWord#` (word16ToWord# y#)))-        | otherwise                 = divZeroError-    div     (W16# x#) y@(W16# y#)-        | y /= 0                    = W16# (wordToWord16# ((word16ToWord# x#) `quotWord#` (word16ToWord# y#)))-        | otherwise                 = divZeroError-    mod     (W16# x#) y@(W16# y#)-        | y /= 0                    = W16# (wordToWord16# ((word16ToWord# x#) `remWord#` (word16ToWord# y#)))-        | otherwise                 = divZeroError-    quotRem (W16# x#) y@(W16# y#)-        | y /= 0                  = case (word16ToWord# x#) `quotRemWord#` (word16ToWord# y#) of-                                    (# q, r #) ->-                                        (W16# (wordToWord16# q), W16# (wordToWord16# r))-        | otherwise                 = divZeroError-    divMod  (W16# x#) y@(W16# y#)-        | y /= 0                    = (W16# (wordToWord16# ((word16ToWord# x#) `quotWord#` (word16ToWord# y#)))-                                      ,W16# (wordToWord16# ((word16ToWord# x#) `remWord#` (word16ToWord# y#))))-        | otherwise                 = divZeroError-    toInteger (W16# x#)             = IS (word2Int# (word16ToWord# x#))---- | @since 2.01-instance Bounded Word16 where-    minBound = 0-    maxBound = 0xFFFF---- | @since 2.01-instance Ix Word16 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral (i - m)-    inRange (m,n) i     = m <= i && i <= n---- | @since 2.01-instance Bits Word16 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (W16# x#) .&.   (W16# y#)  = W16# (wordToWord16# ((word16ToWord# x#) `and#` (word16ToWord# y#)))-    (W16# x#) .|.   (W16# y#)  = W16# (wordToWord16# ((word16ToWord# x#) `or#`  (word16ToWord# y#)))-    (W16# x#) `xor` (W16# y#)  = W16# (wordToWord16# ((word16ToWord# x#) `xor#` (word16ToWord# y#)))-    complement (W16# x#)       = W16# (wordToWord16# (not# (word16ToWord# x#)))-    (W16# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = W16# (wordToWord16# ((word16ToWord# x#) `shiftL#` i#))-        | otherwise            = W16# (wordToWord16# ((word16ToWord# x#) `shiftRL#` negateInt# i#))-    (W16# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = W16# (wordToWord16# ((word16ToWord# x#) `shiftL#` i#))-        | otherwise            = overflowError-    (W16# x#) `unsafeShiftL` (I# i#) =-        W16# (wordToWord16# ((word16ToWord# x#) `uncheckedShiftL#` i#))-    (W16# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = W16# (wordToWord16# ((word16ToWord# x#) `shiftRL#` i#))-        | otherwise            = overflowError-    (W16# x#) `unsafeShiftR` (I# i#) = W16# (wordToWord16# ((word16ToWord# x#) `uncheckedShiftRL#` i#))-    (W16# x#) `rotate`       (I# i#)-        | isTrue# (i'# ==# 0#) = W16# x#-        | otherwise  = W16# (wordToWord16# (((word16ToWord# x#) `uncheckedShiftL#` i'#) `or#`-                                            ((word16ToWord# x#) `uncheckedShiftRL#` (16# -# i'#))))-        where-        !i'# = word2Int# (int2Word# i# `and#` 15##)-    bitSizeMaybe i            = Just (finiteBitSize i)-    bitSize i                 = finiteBitSize i-    isSigned _                = False-    popCount (W16# x#)        = I# (word2Int# (popCnt16# (word16ToWord# x#)))-    bit                       = bitDefault-    testBit                   = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Word16 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 16-    countLeadingZeros  (W16# x#) = I# (word2Int# (clz16# (word16ToWord# x#)))-    countTrailingZeros (W16# x#) = I# (word2Int# (ctz16# (word16ToWord# x#)))---- | Reverse order of bytes in 'Word16'.------ @since 4.7.0.0-byteSwap16 :: Word16 -> Word16-byteSwap16 (W16# w#) = W16# (wordToWord16# (byteSwap16# (word16ToWord# w#)))--{-# RULES-"properFraction/Float->(Word16,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Word16) n, y :: Float) }-"truncate/Float->Word16"-    truncate = (fromIntegral :: Int -> Word16) . (truncate :: Float -> Int)-"floor/Float->Word16"-    floor    = (fromIntegral :: Int -> Word16) . (floor :: Float -> Int)-"ceiling/Float->Word16"-    ceiling  = (fromIntegral :: Int -> Word16) . (ceiling :: Float -> Int)-"round/Float->Word16"-    round    = (fromIntegral :: Int -> Word16) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Word16,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Word16) n, y :: Double) }-"truncate/Double->Word16"-    truncate = (fromIntegral :: Int -> Word16) . (truncate :: Double -> Int)-"floor/Double->Word16"-    floor    = (fromIntegral :: Int -> Word16) . (floor :: Double -> Int)-"ceiling/Double->Word16"-    ceiling  = (fromIntegral :: Int -> Word16) . (ceiling :: Double -> Int)-"round/Double->Word16"-    round    = (fromIntegral :: Int -> Word16) . (round  :: Double -> Int)-  #-}----------------------------------------------------------------------------- type Word32----------------------------------------------------------------------------- Word32 is represented in the same way as Word.-#if WORD_SIZE_IN_BITS > 32--- Operations may assume and must ensure that it holds only values--- from its logical range.---- We can use rewrite rules for the RealFrac methods--{-# RULES-"properFraction/Float->(Word32,Float)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Word32) n, y :: Float) }-"truncate/Float->Word32"-    truncate = (fromIntegral :: Int -> Word32) . (truncate :: Float -> Int)-"floor/Float->Word32"-    floor    = (fromIntegral :: Int -> Word32) . (floor :: Float -> Int)-"ceiling/Float->Word32"-    ceiling  = (fromIntegral :: Int -> Word32) . (ceiling :: Float -> Int)-"round/Float->Word32"-    round    = (fromIntegral :: Int -> Word32) . (round  :: Float -> Int)-  #-}--{-# RULES-"properFraction/Double->(Word32,Double)"-    properFraction = \x ->-                      case properFraction x of {-                        (n, y) -> ((fromIntegral :: Int -> Word32) n, y :: Double) }-"truncate/Double->Word32"-    truncate = (fromIntegral :: Int -> Word32) . (truncate :: Double -> Int)-"floor/Double->Word32"-    floor    = (fromIntegral :: Int -> Word32) . (floor :: Double -> Int)-"ceiling/Double->Word32"-    ceiling  = (fromIntegral :: Int -> Word32) . (ceiling :: Double -> Int)-"round/Double->Word32"-    round    = (fromIntegral :: Int -> Word32) . (round  :: Double -> Int)-  #-}--#endif--data {-# CTYPE "HsWord32" #-} Word32 = W32# Word32#--- ^ 32-bit unsigned integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Word32 where-    (==) = eqWord32-    (/=) = neWord32--eqWord32, neWord32 :: Word32 -> Word32 -> Bool-eqWord32 (W32# x) (W32# y) = isTrue# ((word32ToWord# x) `eqWord#` (word32ToWord# y))-neWord32 (W32# x) (W32# y) = isTrue# ((word32ToWord# x) `neWord#` (word32ToWord# y))-{-# INLINE [1] eqWord32 #-}-{-# INLINE [1] neWord32 #-}---- | @since 2.01-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 `gtWord32#` y)-(W32# x) `geWord32` (W32# y) = isTrue# (x `geWord32#` y)-(W32# x) `ltWord32` (W32# y) = isTrue# (x `ltWord32#` y)-(W32# x) `leWord32` (W32# y) = isTrue# (x `leWord32#` y)---- | @since 2.01-instance Num Word32 where-    (W32# x#) + (W32# y#)  = W32# (wordToWord32# ((word32ToWord# x#) `plusWord#` (word32ToWord# y#)))-    (W32# x#) - (W32# y#)  = W32# (wordToWord32# ((word32ToWord# x#) `minusWord#` (word32ToWord# y#)))-    (W32# x#) * (W32# y#)  = W32# (wordToWord32# ((word32ToWord# x#) `timesWord#` (word32ToWord# y#)))-    negate (W32# x#)       = W32# (wordToWord32# (int2Word# (negateInt# (word2Int# (word32ToWord# x#)))))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W32# (wordToWord32# (integerToWord# i))---- | @since 2.01-instance Enum Word32 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word32"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word32"-    toEnum i@(I# i#)-        | i >= 0-#if WORD_SIZE_IN_BITS > 32-          && i <= fromIntegral (maxBound::Word32)-#endif-                        = W32# (wordToWord32# (int2Word# i#))-        | otherwise     = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)-#if WORD_SIZE_IN_BITS == 32-    fromEnum x@(W32# x#)-        | x <= fromIntegral (maxBound::Int)-                        = I# (word2Int# (word32ToWord# x#))-        | otherwise     = fromEnumError "Word32" x-    enumFrom            = integralEnumFrom-    enumFromThen        = integralEnumFromThen-    enumFromTo          = integralEnumFromTo-    enumFromThenTo      = integralEnumFromThenTo-#else-    fromEnum (W32# x#)  = I# (word2Int# (word32ToWord# x#))-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = boundedEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = boundedEnumFromThen-#endif---- | @since 2.01-instance Integral Word32 where-    quot    (W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (wordToWord32# ((word32ToWord# x#) `quotWord#` (word32ToWord# y#)))-        | otherwise                 = divZeroError-    rem     (W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (wordToWord32# ((word32ToWord# x#) `remWord#` (word32ToWord# y#)))-        | otherwise                 = divZeroError-    div     (W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (wordToWord32# ((word32ToWord# x#) `quotWord#` (word32ToWord# y#)))-        | otherwise                 = divZeroError-    mod     (W32# x#) y@(W32# y#)-        | y /= 0                    = W32# (wordToWord32# ((word32ToWord# x#) `remWord#` (word32ToWord# y#)))-        | otherwise                 = divZeroError-    quotRem (W32# x#) y@(W32# y#)-        | y /= 0                  = case (word32ToWord# x#) `quotRemWord#` (word32ToWord# y#) of-                                    (# q, r #) ->-                                        (W32# (wordToWord32# q), W32# (wordToWord32# r))-        | otherwise                 = divZeroError-    divMod  (W32# x#) y@(W32# y#)-        | y /= 0                    = (W32# (wordToWord32# ((word32ToWord# x#) `quotWord#` (word32ToWord# y#)))-                                      ,W32# (wordToWord32# ((word32ToWord# x#) `remWord#` (word32ToWord# y#))))-        | otherwise                 = divZeroError-    toInteger (W32# x#)             = integerFromWord# (word32ToWord# x#)---- | @since 2.01-instance Bits Word32 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (W32# x#) .&.   (W32# y#)  = W32# (wordToWord32# ((word32ToWord# x#) `and#` (word32ToWord# y#)))-    (W32# x#) .|.   (W32# y#)  = W32# (wordToWord32# ((word32ToWord# x#) `or#`  (word32ToWord# y#)))-    (W32# x#) `xor` (W32# y#)  = W32# (wordToWord32# ((word32ToWord# x#) `xor#` (word32ToWord# y#)))-    complement (W32# x#)       = W32# (wordToWord32# (not# (word32ToWord# x#)))-    (W32# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = W32# (wordToWord32# ((word32ToWord# x#) `shiftL#` i#))-        | otherwise            = W32# (wordToWord32# ((word32ToWord# x#) `shiftRL#` negateInt# i#))-    (W32# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = W32# (wordToWord32# ((word32ToWord# x#) `shiftL#` i#))-        | otherwise            = overflowError-    (W32# x#) `unsafeShiftL` (I# i#) =-        W32# (wordToWord32# ((word32ToWord# x#) `uncheckedShiftL#` i#))-    (W32# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = W32# (wordToWord32# ((word32ToWord# x#) `shiftRL#` i#))-        | otherwise            = overflowError-    (W32# x#) `unsafeShiftR` (I# i#) = W32# (wordToWord32# ((word32ToWord# x#) `uncheckedShiftRL#` i#))-    (W32# x#) `rotate`       (I# i#)-        | isTrue# (i'# ==# 0#) = W32# x#-        | otherwise   = W32# (wordToWord32# (((word32ToWord# x#) `uncheckedShiftL#` i'#) `or#`-                                            ((word32ToWord# x#) `uncheckedShiftRL#` (32# -# i'#))))-        where-        !i'# = word2Int# (int2Word# i# `and#` 31##)-    bitSizeMaybe i            = Just (finiteBitSize i)-    bitSize i                 = finiteBitSize i-    isSigned _                = False-    popCount (W32# x#)        = I# (word2Int# (popCnt32# (word32ToWord# x#)))-    bit                       = bitDefault-    testBit                   = testBitDefault---- | @since 4.6.0.0-instance FiniteBits Word32 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 32-    countLeadingZeros  (W32# x#) = I# (word2Int# (clz32# (word32ToWord# x#)))-    countTrailingZeros (W32# x#) = I# (word2Int# (ctz32# (word32ToWord# x#)))---- | @since 2.01-instance Show Word32 where-#if WORD_SIZE_IN_BITS < 33-    showsPrec p x = showsPrec p (toInteger x)-#else-    showsPrec p x = showsPrec p (fromIntegral x :: Int)-#endif----- | @since 2.01-instance Real Word32 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Bounded Word32 where-    minBound = 0-    maxBound = 0xFFFFFFFF---- | @since 2.01-instance Ix Word32 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral (i - m)-    inRange (m,n) i     = m <= i && i <= n---- | Reverse order of bytes in 'Word32'.------ @since 4.7.0.0-byteSwap32 :: Word32 -> Word32-byteSwap32 (W32# w#) = W32# (wordToWord32# (byteSwap32# (word32ToWord# w#)))----------------------------------------------------------------------------- type Word64---------------------------------------------------------------------------#if WORD_SIZE_IN_BITS < 64--data {-# CTYPE "HsWord64" #-} Word64 = W64# Word64#--- ^ 64-bit unsigned integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-instance Eq Word64 where-    (==) = 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 #-}---- | @since 2.01-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 `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)---- | @since 2.01-instance Num Word64 where-    (W64# x#) + (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#))-    (W64# x#) - (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `subInt64#` word64ToInt64# y#))-    (W64# x#) * (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `timesInt64#` word64ToInt64# y#))-    negate (W64# x#)       = W64# (int64ToWord64# (negateInt64# (word64ToInt64# x#)))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W64# (integerToWord64# i)---- | @since 2.01-instance Enum Word64 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word64"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word64"-    toEnum i@(I# i#)-        | i >= 0        = W64# (wordToWord64# (int2Word# i#))-        | otherwise     = toEnumError "Word64" i (minBound::Word64, maxBound::Word64)-    fromEnum x@(W64# x#)-        | x <= fromIntegral (maxBound::Int)-                        = I# (word2Int# (word64ToWord# x#))-        | otherwise     = fromEnumError "Word64" x-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = integralEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = integralEnumFromThen-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromTo #-}-    enumFromTo          = integralEnumFromTo-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThenTo #-}-    enumFromThenTo      = integralEnumFromThenTo---- | @since 2.01-instance Integral Word64 where-    quot    (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `quotWord64#` y#)-        | otherwise                 = divZeroError-    rem     (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `remWord64#` y#)-        | otherwise                 = divZeroError-    div     (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `quotWord64#` y#)-        | otherwise                 = divZeroError-    mod     (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `remWord64#` y#)-        | otherwise                 = divZeroError-    quotRem (W64# x#) y@(W64# y#)-        | y /= 0                    = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))-        | otherwise                 = divZeroError-    divMod  (W64# x#) y@(W64# y#)-        | y /= 0                    = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))-        | otherwise                 = divZeroError-    toInteger (W64# x#)             = integerFromWord64# x#---- | @since 2.01-instance Bits Word64 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (W64# x#) .&.   (W64# y#)  = W64# (x# `and64#` y#)-    (W64# x#) .|.   (W64# y#)  = W64# (x# `or64#`  y#)-    (W64# x#) `xor` (W64# y#)  = W64# (x# `xor64#` y#)-    complement (W64# x#)       = W64# (not64# x#)-    (W64# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = W64# (x# `shiftL64#` i#)-        | otherwise            = W64# (x# `shiftRL64#` negateInt# i#)-    (W64# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = W64# (x# `shiftL64#` i#)-        | otherwise            = overflowError-    (W64# x#) `unsafeShiftL` (I# i#) = W64# (x# `uncheckedShiftL64#` i#)-    (W64# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = W64# (x# `shiftRL64#` i#)-        | otherwise            = overflowError-    (W64# x#) `unsafeShiftR` (I# i#) = W64# (x# `uncheckedShiftRL64#` i#)-    (W64# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#) = W64# x#-        | otherwise            = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`-                                       (x# `uncheckedShiftRL64#` (64# -# i'#)))-        where-        !i'# = word2Int# (int2Word# i# `and#` 63##)-    bitSizeMaybe i            = Just (finiteBitSize i)-    bitSize i                 = finiteBitSize i-    isSigned _                = False-    popCount (W64# x#)        = I# (word2Int# (popCnt64# x#))-    bit                       = bitDefault-    testBit                   = testBitDefault---- give the 64-bit shift operations the same treatment as the 32-bit--- ones (see GHC.Base), namely we wrap them in tests to catch the--- cases when we're shifting more than 64 bits to avoid unspecified--- behaviour in the C shift operations.--shiftL64#, shiftRL64# :: Word64# -> Int# -> Word64#--a `shiftL64#` b  | isTrue# (b >=# 64#) = wordToWord64# 0##-                 | otherwise           = a `uncheckedShiftL64#` b--a `shiftRL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0##-                 | otherwise           = a `uncheckedShiftRL64#` b--#else---- Word64 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 "HsWord64" #-} Word64 = W64# Word#--- ^ 64-bit unsigned integer type---- See GHC.Classes#matching_overloaded_methods_in_rules--- | @since 2.01-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 #-}---- | @since 2.01-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)---- | @since 2.01-instance Num Word64 where-    (W64# x#) + (W64# y#)  = W64# (x# `plusWord#` y#)-    (W64# x#) - (W64# y#)  = W64# (x# `minusWord#` y#)-    (W64# x#) * (W64# y#)  = W64# (x# `timesWord#` y#)-    negate (W64# x#)       = W64# (int2Word# (negateInt# (word2Int# x#)))-    abs x                  = x-    signum 0               = 0-    signum _               = 1-    fromInteger i          = W64# (integerToWord# i)---- | @since 2.01-instance Enum Word64 where-    succ x-        | x /= maxBound = x + 1-        | otherwise     = succError "Word64"-    pred x-        | x /= minBound = x - 1-        | otherwise     = predError "Word64"-    toEnum i@(I# i#)-        | i >= 0        = W64# (int2Word# i#)-        | otherwise     = toEnumError "Word64" i (minBound::Word64, maxBound::Word64)-    fromEnum x@(W64# x#)-        | x <= fromIntegral (maxBound::Int)-                        = I# (word2Int# x#)-        | otherwise     = fromEnumError "Word64" x--#if WORD_SIZE_IN_BITS < 64-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFrom #-}-    enumFrom            = integralEnumFrom-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThen #-}-    enumFromThen        = integralEnumFromThen-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromTo #-}-    enumFromTo          = integralEnumFromTo-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINE enumFromThenTo #-}-    enumFromThenTo      = integralEnumFromThenTo-#else-    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINABLE enumFrom #-}-    enumFrom w-        = map wordToWord64-        $ enumFrom (word64ToWord w)--    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINABLE enumFromThen #-}-    enumFromThen w s-        = map wordToWord64-        $ enumFromThen (word64ToWord w) (word64ToWord s)--    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINABLE enumFromTo #-}-    enumFromTo w1 w2-        = map wordToWord64-        $ enumFromTo (word64ToWord w1) (word64ToWord w2)--    -- See Note [Stable Unfolding for list producers] in GHC.Enum-    {-# INLINABLE enumFromThenTo #-}-    enumFromThenTo w1 s w2-        = map wordToWord64-        $ enumFromThenTo (word64ToWord w1) (word64ToWord s) (word64ToWord w2)--word64ToWord :: Word64 -> Word-word64ToWord (W64# w#) = (W# w#)--wordToWord64 :: Word -> Word64-wordToWord64 (W# w#) = (W64# w#)-#endif----- | @since 2.01-instance Integral Word64 where-    quot    (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `quotWord#` y#)-        | otherwise                 = divZeroError-    rem     (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `remWord#` y#)-        | otherwise                 = divZeroError-    div     (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `quotWord#` y#)-        | otherwise                 = divZeroError-    mod     (W64# x#) y@(W64# y#)-        | y /= 0                    = W64# (x# `remWord#` y#)-        | otherwise                 = divZeroError-    quotRem (W64# x#) y@(W64# y#)-        | y /= 0                  = case x# `quotRemWord#` y# of-                                    (# q, r #) ->-                                        (W64# q, W64# r)-        | otherwise                 = divZeroError-    divMod  (W64# x#) y@(W64# y#)-        | y /= 0                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))-        | otherwise                 = divZeroError-    toInteger (W64# x#)             = integerFromWord# x#---- | @since 2.01-instance Bits Word64 where-    {-# INLINE shift #-}-    {-# INLINE bit #-}-    {-# INLINE testBit #-}-    {-# INLINE popCount #-}--    (W64# x#) .&.   (W64# y#)  = W64# (x# `and#` y#)-    (W64# x#) .|.   (W64# y#)  = W64# (x# `or#`  y#)-    (W64# x#) `xor` (W64# y#)  = W64# (x# `xor#` y#)-    complement (W64# x#)       = W64# (not# x#)-    (W64# x#) `shift` (I# i#)-        | isTrue# (i# >=# 0#)  = W64# (x# `shiftL#` i#)-        | otherwise            = W64# (x# `shiftRL#` negateInt# i#)-    (W64# x#) `shiftL`       (I# i#)-        | isTrue# (i# >=# 0#)  = W64# (x# `shiftL#` i#)-        | otherwise            = overflowError-    (W64# x#) `unsafeShiftL` (I# i#) = W64# (x# `uncheckedShiftL#` i#)-    (W64# x#) `shiftR`       (I# i#)-        | isTrue# (i# >=# 0#)  = W64# (x# `shiftRL#` i#)-        | otherwise            = overflowError-    (W64# x#) `unsafeShiftR` (I# i#) = W64# (x# `uncheckedShiftRL#` i#)-    (W64# x#) `rotate` (I# i#)-        | isTrue# (i'# ==# 0#) = W64# x#-        | otherwise            = W64# ((x# `uncheckedShiftL#` i'#) `or#`-                                       (x# `uncheckedShiftRL#` (64# -# i'#)))-        where-        !i'# = word2Int# (int2Word# i# `and#` 63##)-    bitSizeMaybe i            = Just (finiteBitSize i)-    bitSize i                 = finiteBitSize i-    isSigned _                = False-    popCount (W64# x#)        = I# (word2Int# (popCnt64# x#))-    bit                       = bitDefault-    testBit                   = testBitDefault--uncheckedShiftL64# :: Word# -> Int# -> Word#-uncheckedShiftL64#  = uncheckedShiftL#--uncheckedShiftRL64# :: Word# -> Int# -> Word#-uncheckedShiftRL64# = uncheckedShiftRL#--#endif---- | @since 4.6.0.0-instance FiniteBits Word64 where-    {-# INLINE countLeadingZeros #-}-    {-# INLINE countTrailingZeros #-}-    finiteBitSize _ = 64-    countLeadingZeros  (W64# x#) = I# (word2Int# (clz64# x#))-    countTrailingZeros (W64# x#) = I# (word2Int# (ctz64# x#))---- | @since 2.01-instance Show Word64 where-    showsPrec p x = showsPrec p (toInteger x)---- | @since 2.01-instance Real Word64 where-    toRational x = toInteger x % 1---- | @since 2.01-instance Bounded Word64 where-    minBound = 0-    maxBound = 0xFFFFFFFFFFFFFFFF---- | @since 2.01-instance Ix Word64 where-    range (m,n)         = [m..n]-    unsafeIndex (m,_) i = fromIntegral (i - m)-    inRange (m,n) i     = m <= i && i <= n---- | Reverse order of bytes in 'Word64'.------ @since 4.7.0.0-#if WORD_SIZE_IN_BITS < 64-byteSwap64 :: Word64 -> Word64-byteSwap64 (W64# w#) = W64# (byteSwap64# w#)-#else-byteSwap64 :: Word64 -> Word64-byteSwap64 (W64# w#) = W64# (byteSwap# w#)-#endif---- | Reverse the order of the bits in a 'Word8'.------ @since 4.14.0.0-bitReverse8 :: Word8 -> Word8-bitReverse8 (W8# w#) = W8# (wordToWord8# (bitReverse8# (word8ToWord# w#)))---- | Reverse the order of the bits in a 'Word16'.------ @since 4.14.0.0-bitReverse16 :: Word16 -> Word16-bitReverse16 (W16# w#) = W16# (wordToWord16# (bitReverse16# (word16ToWord# w#)))---- | Reverse the order of the bits in a 'Word32'.------ @since 4.14.0.0-bitReverse32 :: Word32 -> Word32-bitReverse32 (W32# w#) = W32# (wordToWord32# (bitReverse32# (word32ToWord# w#)))---- | Reverse the order of the bits in a 'Word64'.------ @since 4.14.0.0-#if WORD_SIZE_IN_BITS < 64-bitReverse64 :: Word64 -> Word64-bitReverse64 (W64# w#) = W64# (bitReverse64# w#)-#else-bitReverse64 :: Word64 -> Word64-bitReverse64 (W64# w#) = W64# (bitReverse# w#)-#endif-
− Numeric.hs 
@@ -1,304 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude, MagicHash #-}---------------------------------------------------------------------------------- |--- Module      :  Numeric--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Odds and ends, mostly functions for reading and showing--- 'RealFloat'-like kind of values.-----------------------------------------------------------------------------------module Numeric (--        -- * Showing--        showSigned,--        showIntAtBase,-        showInt,-        showBin,-        showHex,-        showOct,--        showEFloat,-        showFFloat,-        showGFloat,-        showFFloatAlt,-        showGFloatAlt,-        showFloat,-        showHFloat,--        floatToDigits,--        -- * Reading--        -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase',-        -- and 'readDec' is the \`dual\' of 'showInt'.-        -- The inconsistent naming is a historical accident.--        readSigned,--        readInt,-        readBin,-        readDec,-        readOct,-        readHex,--        readFloat,--        lexDigits,--        -- * Miscellaneous--        fromRat,-        Floating(..)--        ) where--import GHC.Base-import GHC.Read-import GHC.Real-import GHC.Float-import GHC.Num-import GHC.Show-import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail )-import qualified Text.Read.Lex as L---- $setup--- >>> import Prelude---- -------------------------------------------------------------------------------- Reading---- | Reads an /unsigned/ 'Integral' value in an arbitrary base.-readInt :: Num a-  => a                  -- ^ the base-  -> (Char -> Bool)     -- ^ a predicate distinguishing valid digits in this base-  -> (Char -> Int)      -- ^ a function converting a valid digit character to an 'Int'-  -> ReadS a-readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit)---- | Read an unsigned number in binary notation.------ >>> readBin "10011"--- [(19,"")]-readBin :: (Eq a, Num a) => ReadS a-readBin = readP_to_S L.readBinP---- | Read an unsigned number in octal notation.------ >>> readOct "0644"--- [(420,"")]-readOct :: (Eq a, Num a) => ReadS a-readOct = readP_to_S L.readOctP---- | Read an unsigned number in decimal notation.------ >>> readDec "0644"--- [(644,"")]-readDec :: (Eq a, Num a) => ReadS a-readDec = readP_to_S L.readDecP---- | Read an unsigned number in hexadecimal notation.--- Both upper or lower case letters are allowed.------ >>> readHex "deadbeef"--- [(3735928559,"")]-readHex :: (Eq a, Num a) => ReadS a-readHex = readP_to_S L.readHexP---- | Reads an /unsigned/ 'RealFrac' value,--- expressed in decimal scientific notation.-readFloat :: RealFrac a => ReadS a-readFloat = readP_to_S readFloatP--readFloatP :: RealFrac a => ReadP a-readFloatP =-  do tok <- L.lex-     case tok of-       L.Number n -> return $ fromRational $ L.numberToRational n-       _          -> pfail---- It's turgid to have readSigned work using list comprehensions,--- but it's specified as a ReadS to ReadS transformer--- With a bit of luck no one will use it.---- | Reads a /signed/ 'Real' value, given a reader for an unsigned value.-readSigned :: (Real a) => ReadS a -> ReadS a-readSigned readPos = readParen False read'-                     where read' r  = read'' r ++-                                      (do-                                        ("-",s) <- lex r-                                        (x,t)   <- read'' s-                                        return (-x,t))-                           read'' r = do-                               (str,s) <- lex r-                               (n,"")  <- readPos str-                               return (n,s)---- -------------------------------------------------------------------------------- Showing---- | Show /non-negative/ 'Integral' numbers in base 10.-showInt :: Integral a => a -> ShowS-showInt n0 cs0-    | n0 < 0    = errorWithoutStackTrace "Numeric.showInt: can't show negative numbers"-    | otherwise = go n0 cs0-    where-    go n cs-        | n < 10    = case unsafeChr (ord '0' + fromIntegral n) of-            c@(C# _) -> c:cs-        | otherwise = case unsafeChr (ord '0' + fromIntegral r) of-            c@(C# _) -> go q (c:cs)-        where-        (q,r) = n `quotRem` 10---- Controlling the format and precision of floats. The code that--- implements the formatting itself is in @PrelNum@ to avoid--- mutual module deps.--{-# SPECIALIZE showEFloat ::-        Maybe Int -> Float  -> ShowS,-        Maybe Int -> Double -> ShowS #-}-{-# SPECIALIZE showFFloat ::-        Maybe Int -> Float  -> ShowS,-        Maybe Int -> Double -> ShowS #-}-{-# SPECIALIZE showGFloat ::-        Maybe Int -> Float  -> ShowS,-        Maybe Int -> Double -> ShowS #-}---- | Show a signed 'RealFloat' value--- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@).------ In the call @'showEFloat' digs val@, if @digs@ is 'Nothing',--- the value is shown to full precision; if @digs@ is @'Just' d@,--- then at most @d@ digits after the decimal point are shown.-showEFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS---- | Show a signed 'RealFloat' value--- using standard decimal notation (e.g. @245000@, @0.0015@).------ In the call @'showFFloat' digs val@, if @digs@ is 'Nothing',--- the value is shown to full precision; if @digs@ is @'Just' d@,--- then at most @d@ digits after the decimal point are shown.-showFFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS---- | Show a signed 'RealFloat' value--- using standard decimal notation for arguments whose absolute value lies--- between @0.1@ and @9,999,999@, and scientific notation otherwise.------ In the call @'showGFloat' digs val@, if @digs@ is 'Nothing',--- the value is shown to full precision; if @digs@ is @'Just' d@,--- then at most @d@ digits after the decimal point are shown.-showGFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS--showEFloat d x =  showString (formatRealFloat FFExponent d x)-showFFloat d x =  showString (formatRealFloat FFFixed d x)-showGFloat d x =  showString (formatRealFloat FFGeneric d x)---- | Show a signed 'RealFloat' value--- using standard decimal notation (e.g. @245000@, @0.0015@).------ This behaves as 'showFFloat', except that a decimal point--- is always guaranteed, even if not needed.------ @since 4.7.0.0-showFFloatAlt    :: (RealFloat a) => Maybe Int -> a -> ShowS---- | Show a signed 'RealFloat' value--- using standard decimal notation for arguments whose absolute value lies--- between @0.1@ and @9,999,999@, and scientific notation otherwise.------ This behaves as 'showFFloat', except that a decimal point--- is always guaranteed, even if not needed.------ @since 4.7.0.0-showGFloatAlt    :: (RealFloat a) => Maybe Int -> a -> ShowS--showFFloatAlt d x =  showString (formatRealFloatAlt FFFixed d True x)-showGFloatAlt d x =  showString (formatRealFloatAlt FFGeneric d True x)--{- | Show a floating-point value in the hexadecimal format,-similar to the @%a@ specifier in C's printf.--  >>> showHFloat (212.21 :: Double) ""-  "0x1.a86b851eb851fp7"-  >>> showHFloat (-12.76 :: Float) ""-  "-0x1.9851ecp3"-  >>> showHFloat (-0 :: Double) ""-  "-0x0p+0"--}-showHFloat :: RealFloat a => a -> ShowS-showHFloat = showString . fmt-  where-  fmt x-    | isNaN x                   = "NaN"-    | isInfinite x              = (if x < 0 then "-" else "") ++ "Infinity"-    | x < 0 || isNegativeZero x = '-' : cvt (-x)-    | otherwise                 = cvt x--  cvt x-    | x == 0 = "0x0p+0"-    | otherwise =-      case floatToDigits 2 x of-        r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r-        (d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1)--  -- Given binary digits, convert them to hex in blocks of 4-  -- Special case: If all 0's, just drop it.-  frac digits-    | allZ digits = ""-    | otherwise   = "." ++ hex digits-    where-    hex ds =-      case ds of-        []                -> ""-        [a]               -> hexDigit a 0 0 0 ""-        [a,b]             -> hexDigit a b 0 0 ""-        [a,b,c]           -> hexDigit a b c 0 ""-        a : b : c : d : r -> hexDigit a b c d (hex r)--  hexDigit a b c d = showHex (8*a + 4*b + 2*c + d)--  allZ xs = case xs of-              x : more -> x == 0 && allZ more-              []       -> True---- ------------------------------------------------------------------------------ Integer printing functions---- | Shows a /non-negative/ 'Integral' number using the base specified by the--- 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 = 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-      case n of-        0 -> r'-        _ -> showIt (quotRem n base) r'-     where-      c  = toChr (fromIntegral d)-      r' = c : r---- | Show /non-negative/ 'Integral' numbers in base 16.-showHex :: (Integral a,Show a) => a -> ShowS-showHex = showIntAtBase 16 intToDigit---- | Show /non-negative/ 'Integral' numbers in base 8.-showOct :: (Integral a, Show a) => a -> ShowS-showOct = showIntAtBase 8  intToDigit---- | Show /non-negative/ 'Integral' numbers in base 2.-showBin :: (Integral a, Show a) => a -> ShowS-showBin = showIntAtBase 2  intToDigit
− Numeric/Natural.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  Numeric.Natural--- Copyright   :  (C) 2014 Herbert Valerio Riedel,---                (C) 2011 Edward Kmett--- License     :  see libraries/base/LICENSE------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ The arbitrary-precision 'Natural' number type.------ @since 4.8.0.0--------------------------------------------------------------------------------module Numeric.Natural-    ( Natural-    ) where--import GHC.Num.Natural
− Prelude.hs 
@@ -1,182 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Prelude--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ The Prelude: a standard module. The Prelude is imported by default--- into all Haskell modules unless either there is an explicit import--- statement for it, or the NoImplicitPrelude extension is enabled.-----------------------------------------------------------------------------------module Prelude (--    -- * Standard types, classes and related functions--    -- ** Basic data types-    Bool(False, True),-    (&&), (||), not, otherwise,--    Maybe(Nothing, Just),-    maybe,--    Either(Left, Right),-    either,--    Ordering(LT, EQ, GT),-    Char, String,--    -- *** Tuples-    fst, snd, curry, uncurry,--    -- ** Basic type classes-    Eq((==), (/=)),-    Ord(compare, (<), (<=), (>=), (>), max, min),-    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,-         enumFromTo, enumFromThenTo),-    Bounded(minBound, maxBound),--    -- ** Numbers--    -- *** Numeric types-    Int, Integer, Float, Double,-    Rational, Word,--    -- *** Numeric type classes-    Num((+), (-), (*), negate, abs, signum, fromInteger),-    Real(toRational),-    Integral(quot, rem, div, mod, quotRem, divMod, toInteger),-    Fractional((/), recip, fromRational),-    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,-             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),-    RealFrac(properFraction, truncate, round, ceiling, floor),-    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,-              encodeFloat, exponent, significand, scaleFloat, isNaN,-              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),--    -- *** Numeric functions-    subtract, even, odd, gcd, lcm, (^), (^^),-    fromIntegral, realToFrac,--    -- ** Semigroups and Monoids-    Semigroup((<>)),-    Monoid(mempty, mappend, mconcat),--    -- ** Monads and functors-    Functor(fmap, (<$)), (<$>),-    Applicative(pure, (<*>), (*>), (<*)),-    Monad((>>=), (>>), return),-    MonadFail(fail),-    mapM_, sequence_, (=<<),--    -- ** Folds and traversals-    Foldable(elem,      -- :: (Foldable t, Eq a) => a -> t a -> Bool-             -- fold,   -- :: Monoid m => t m -> m-             foldMap,   -- :: Monoid m => (a -> m) -> t a -> m-             foldr,     -- :: (a -> b -> b) -> b -> t a -> b-             -- foldr', -- :: (a -> b -> b) -> b -> t a -> b-             foldl,     -- :: (b -> a -> b) -> b -> t a -> b-             -- foldl', -- :: (b -> a -> b) -> b -> t a -> b-             foldr1,    -- :: (a -> a -> a) -> t a -> a-             foldl1,    -- :: (a -> a -> a) -> t a -> a-             maximum,   -- :: (Foldable t, Ord a) => t a -> a-             minimum,   -- :: (Foldable t, Ord a) => t a -> a-             product,   -- :: (Foldable t, Num a) => t a -> a-             sum),      -- :: Num a => t a -> a-             -- toList) -- :: Foldable t => t a -> [a]--    Traversable(traverse, sequenceA, mapM, sequence),--    -- ** Miscellaneous functions-    id, const, (.), flip, ($), until,-    asTypeOf, error, errorWithoutStackTrace, undefined,-    seq, ($!),--    -- * List operations-    List.map, (List.++), List.filter,-    List.head, List.last, List.tail, List.init, (List.!!),-    Foldable.null, Foldable.length,-    List.reverse,-    -- *** Special folds-    Foldable.and, Foldable.or, Foldable.any, Foldable.all,-    Foldable.concat, Foldable.concatMap,-    -- ** Building lists-    -- *** Scans-    List.scanl, List.scanl1, List.scanr, List.scanr1,-    -- *** Infinite lists-    List.iterate, List.repeat, List.replicate, List.cycle,-    -- ** Sublists-    List.take, List.drop,-    List.takeWhile, List.dropWhile,-    List.span, List.break,-    List.splitAt,-    -- ** Searching lists-    Foldable.notElem,-    List.lookup,-    -- ** Zipping and unzipping lists-    List.zip, List.zip3,-    List.zipWith, List.zipWith3,-    List.unzip, List.unzip3,-    -- ** Functions on strings-    List.lines, List.words, List.unlines, List.unwords,--    -- * Converting to and from @String@-    -- ** Converting to @String@-    ShowS,-    Show(showsPrec, showList, show),-    shows,-    showChar, showString, showParen,-    -- ** Converting from @String@-    ReadS,-    Read(readsPrec, readList),-    reads, readParen, read, lex,--    -- * Basic Input and output-    IO,-    -- ** Simple I\/O operations-    -- All I/O functions defined here are character oriented.  The-    -- treatment of the newline character will vary on different systems.-    -- For example, two characters of input, return and linefeed, may-    -- read as a single newline character.  These functions cannot be-    -- used portably for binary I/O.-    -- *** Output functions-    putChar,-    putStr, putStrLn, print,-    -- *** Input functions-    getChar,-    getLine, getContents, interact,-    -- *** Files-    FilePath,-    readFile, writeFile, appendFile, readIO, readLn,-    -- ** Exception handling in the I\/O monad-    IOError, ioError, userError,--  ) where--import Control.Monad-import System.IO-import System.IO.Error-import qualified Data.List as List-import Data.Either-import Data.Foldable    ( Foldable(..) )-import qualified Data.Foldable as Foldable-import Data.Functor     ( (<$>) )-import Data.Maybe-import Data.Traversable ( Traversable(..) )-import Data.Tuple--import GHC.Base hiding ( foldr, mapM, sequence )-import Text.Read-import GHC.Enum-import GHC.Num-import GHC.Real-import GHC.Float-import GHC.Show
− Setup.hs 
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMainWithHooks autoconfUserHooks
− System/CPUTime.hsc 
@@ -1,67 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, CApiFFI #-}---------------------------------------------------------------------------------- |--- 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------ The standard CPUTime library.-----------------------------------------------------------------------------------#include "HsFFI.h"-#include "HsBaseConfig.h"---- For various _POSIX_* #defines-#if defined(HAVE_UNISTD_H)-#include <unistd.h>-#endif--module System.CPUTime-    ( getCPUTime-    , cpuTimePrecision-    ) where--import System.IO.Unsafe (unsafePerformIO)---- Here is where we decide which backend to use-#if defined(mingw32_HOST_OS)-import qualified System.CPUTime.Windows as I--#elif _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0-import qualified System.CPUTime.Posix.ClockGetTime as I--#elif defined(HAVE_GETRUSAGE) && ! solaris2_HOST_OS-import qualified System.CPUTime.Posix.RUsage as I---- @getrusage()@ is right royal pain to deal with when targeting 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--- again in libucb in 2.6..)------ Avoid the problem by resorting to times() instead.-#elif defined(HAVE_TIMES)-import qualified System.CPUTime.Posix.Times as I--#else-import qualified System.CPUTime.Unsupported as I-#endif---- | The 'cpuTimePrecision' constant is the smallest measurable difference--- in CPU time that the implementation can record, and is given as an--- integral number of picoseconds.-cpuTimePrecision :: Integer-cpuTimePrecision = unsafePerformIO I.getCpuTimePrecision-{-# NOINLINE cpuTimePrecision #-}---- | Computation 'getCPUTime' returns the number of picoseconds CPU time--- used by the current program.  The precision of this result is--- implementation-dependent.-getCPUTime :: IO Integer-getCPUTime = I.getCPUTime
− System/CPUTime/Posix/ClockGetTime.hsc 
@@ -1,55 +0,0 @@-{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}--#include "HsFFI.h"-#include "HsBaseConfig.h"-#if HAVE_TIME_H-#include <unistd.h>-#include <time.h>-#endif--module System.CPUTime.Posix.ClockGetTime-    ( getCPUTime-    , getCpuTimePrecision-    ) where--#if _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0--import Foreign-import Foreign.C-import System.CPUTime.Utils--getCPUTime :: IO Integer-getCPUTime = fmap snd $ withTimespec $ \ts ->-    throwErrnoIfMinus1_ "clock_gettime"-    $ clock_gettime (#const CLOCK_PROCESS_CPUTIME_ID) ts--getCpuTimePrecision :: IO Integer-getCpuTimePrecision = fmap snd $ withTimespec $ \ts ->-    throwErrnoIfMinus1_ "clock_getres"-    $ clock_getres (#const CLOCK_PROCESS_CPUTIME_ID) ts--data Timespec---- | Perform the given action to fill in a @struct timespec@, returning the--- result of the action and the value of the @timespec@ in picoseconds.-withTimespec :: (Ptr Timespec -> IO a) -> IO (a, Integer)-withTimespec action =-    allocaBytes (# const sizeof(struct timespec)) $ \p_ts -> do-        r <- action p_ts-        u_sec  <- (#peek struct timespec,tv_sec)  p_ts :: IO CTime-        u_nsec <- (#peek struct timespec,tv_nsec) p_ts :: IO CLong-        return (r, cTimeToInteger u_sec * 1e12 + fromIntegral u_nsec * 1e3)--foreign import capi unsafe "time.h clock_getres"  clock_getres  :: CInt -> Ptr Timespec -> IO CInt-foreign import capi unsafe "time.h clock_gettime" clock_gettime :: CInt -> Ptr Timespec -> IO CInt--#else---- This should never happen-getCPUTime :: IO Integer-getCPUTime = error "System.CPUTime.Posix.ClockGetTime: Unsupported"--getCpuTimePrecision :: IO Integer-getCpuTimePrecision = error "System.CPUTime.Posix.ClockGetTime: Unsupported"--#endif // _POSIX_CPUTIME
− System/CPUTime/Posix/RUsage.hsc 
@@ -1,42 +0,0 @@-{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}--#include "HsFFI.h"-#include "HsBaseConfig.h"--module System.CPUTime.Posix.RUsage-    ( getCPUTime-    , getCpuTimePrecision-    ) where--import Data.Ratio-import Foreign-import Foreign.C-import System.CPUTime.Utils---- For struct rusage-#if HAVE_SYS_RESOURCE_H-#include <sys/resource.h>-#endif--getCPUTime :: IO Integer-getCPUTime = allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do-    throwErrnoIfMinus1_ "getrusage" $ getrusage (#const RUSAGE_SELF) p_rusage--    let ru_utime = (#ptr struct rusage, ru_utime) p_rusage-    let ru_stime = (#ptr struct rusage, ru_stime) p_rusage-    u_sec  <- (#peek struct timeval,tv_sec)  ru_utime :: IO CTime-    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-    let usec = cTimeToInteger u_sec * 1e6 + csuSecondsToInteger u_usec +-               cTimeToInteger s_sec * 1e6 + csuSecondsToInteger s_usec-    return (usec * 1e6)--type CRUsage = ()-foreign import capi unsafe "HsBase.h getrusage" getrusage :: CInt -> Ptr CRUsage -> IO CInt--getCpuTimePrecision :: IO Integer-getCpuTimePrecision =-    return $ round ((1e12::Integer) % fromIntegral clk_tck)--foreign import ccall unsafe clk_tck :: CLong
− System/CPUTime/Posix/Times.hsc 
@@ -1,39 +0,0 @@-{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}--#include "HsFFI.h"-#include "HsBaseConfig.h"--module System.CPUTime.Posix.Times-    ( getCPUTime-    , getCpuTimePrecision-    ) where--import Data.Ratio-import Foreign-import Foreign.C-import System.CPUTime.Utils---- for struct tms-#if HAVE_SYS_TIMES_H-#include <sys/times.h>-#endif--getCPUTime :: IO Integer-getCPUTime = allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do-    _ <- 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 (( (cClockToInteger u_ticks + cClockToInteger s_ticks) * 1e12)-                        `div` fromIntegral clockTicks)--type CTms = ()-foreign import ccall unsafe times :: Ptr CTms -> IO CClock--getCpuTimePrecision :: IO Integer-getCpuTimePrecision =-    return $ round ((1e12::Integer) % clockTicks)--foreign import ccall unsafe clk_tck :: CLong--clockTicks :: Integer-clockTicks = fromIntegral clk_tck
− System/CPUTime/Unsupported.hs 
@@ -1,20 +0,0 @@-module System.CPUTime.Unsupported-    ( getCPUTime-    , getCpuTimePrecision-    ) where--import GHC.IO.Exception--getCPUTime :: IO Integer-getCPUTime =-    ioError (IOError Nothing UnsupportedOperation-                     "getCPUTime"-                     "can't get CPU time"-                     Nothing Nothing)--getCpuTimePrecision :: IO Integer-getCpuTimePrecision =-    ioError (IOError Nothing UnsupportedOperation-                     "cpuTimePrecision"-                     "can't get CPU time"-                     Nothing Nothing)
− System/CPUTime/Utils.hs 
@@ -1,19 +0,0 @@-module System.CPUTime.Utils-    ( -- * Integer conversions-      -- | These types have no 'Integral' instances in the Haskell report-      -- so we must do this ourselves.-      cClockToInteger-    , cTimeToInteger-    , csuSecondsToInteger-    ) where--import Foreign.C.Types--cClockToInteger :: CClock -> Integer-cClockToInteger (CClock n) = fromIntegral n--cTimeToInteger :: CTime -> Integer-cTimeToInteger (CTime n) = fromIntegral n--csuSecondsToInteger :: CSUSeconds -> Integer-csuSecondsToInteger (CSUSeconds n) = fromIntegral n
− System/CPUTime/Windows.hsc 
@@ -1,63 +0,0 @@-{-# LANGUAGE CPP, CApiFFI, NondecreasingIndentation, NumDecimals #-}--#include "HsFFI.h"-#include "HsBaseConfig.h"--module System.CPUTime.Windows-    ( getCPUTime-    , getCpuTimePrecision-    ) where--import Foreign-import Foreign.C---- For FILETIME etc. on Windows-#if HAVE_WINDOWS_H-#include <windows.h>-#endif--getCPUTime :: IO Integer-getCPUTime = do-     -- NOTE: GetProcessTimes() is only supported on NT-based OSes.-     -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units.-    allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do-    allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do-    allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do-    allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do-    pid <- getCurrentProcess-    ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime-    if toBool ok then do-      ut <- ft2psecs p_userTime-      kt <- ft2psecs p_kernelTime-      return (ut + kt)-     else return 0-  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)-            -- => multiply by 10^5.-          return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000)--    -- ToDo: pin down elapsed times to just the OS thread(s) that-    -- are evaluating/managing Haskell code.---- While it's hard to get reliable numbers, the consensus is that Windows only provides--- 16 millisecond resolution in GetProcessTimes (see Python PEP 0418)-getCpuTimePrecision :: IO Integer-getCpuTimePrecision = return 16e9--type FILETIME = ()-type HANDLE = ()---- need proper Haskell names (initial lower-case character)-#if defined(i386_HOST_ARCH)-foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)-foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt-#elif defined(x86_64_HOST_ARCH)-foreign import ccall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)-foreign import ccall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt-#else-#error Unknown mingw32 arch-#endif
− System/Console/GetOpt.hs 
@@ -1,410 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  System.Console.GetOpt--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ This library provides facilities for parsing the command-line options--- in a standalone program.  It is essentially a Haskell port of the GNU --- @getopt@ library.-----------------------------------------------------------------------------------{--Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small-changes Dec. 1997)--Two rather obscure features are missing: The Bash 2.0 non-option hack-(if you don't already know it, you probably don't want to hear about-it...) and the recognition of long options with a single dash-(e.g. '-help' is recognised as '--help', as long as there is no short-option 'h').--Other differences between GNU's getopt and this implementation:--* To enforce a coherent description of options and arguments, there-  are explanation fields in the option/argument descriptor.--* Error messages are now more informative, but no longer POSIX-  compliant... :-(--And a final Haskell advertisement: The GNU C implementation uses well-over 1100 lines, we need only 195 here, including a 46 line example! -:-)--}--module System.Console.GetOpt (-   -- * GetOpt-   getOpt, getOpt',-   usageInfo,-   ArgOrder(..),-   OptDescr(..),-   ArgDescr(..),--   -- * Examples--   -- |To hopefully illuminate the role of the different data structures,-   -- here are the command-line options for a (very simple) compiler,-   -- done in two different ways.-   -- The difference arises because the type of 'getOpt' is-   -- parameterized by the type of values derived from flags.--   -- ** Interpreting flags as concrete values-   -- $example1--   -- ** Interpreting flags as transformations of an options record-   -- $example2-) where--import Data.List ( isPrefixOf, find )---- |What to do with options following non-options-data ArgOrder a-  = RequireOrder                -- ^ no option processing after first non-option-  | Permute                     -- ^ freely intersperse options and non-options-  | ReturnInOrder (String -> a) -- ^ wrap non-options into options--{-|-Each 'OptDescr' describes a single option.--The arguments to 'Option' are:--* list of short option characters--* list of long option strings (without \"--\")--* argument descriptor--* explanation of option for user--}-data OptDescr a =              -- description of a single options:-   Option [Char]                --    list of short option characters-          [String]              --    list of long option strings (without "--")-          (ArgDescr a)          --    argument descriptor-          String                --    explanation of option for user---- |Describes whether an option takes an argument or not, and if so--- how the argument is injected into a value of type @a@.-data ArgDescr a-   = NoArg                   a         -- ^   no argument expected-   | ReqArg (String       -> a) String -- ^   option requires argument-   | OptArg (Maybe String -> a) String -- ^   optional argument---- | @since 4.6.0.0-instance Functor ArgOrder where-    fmap _ RequireOrder      = RequireOrder-    fmap _ Permute           = Permute-    fmap f (ReturnInOrder g) = ReturnInOrder (f . g)---- | @since 4.6.0.0-instance Functor OptDescr where-    fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c---- | @since 4.6.0.0-instance Functor ArgDescr where-    fmap f (NoArg a)    = NoArg (f a)-    fmap f (ReqArg g s) = ReqArg (f . g) s-    fmap f (OptArg g s) = OptArg (f . g) s--data OptKind a                -- kind of cmd line arg (internal use only):-   = Opt       a                --    an option-   | UnreqOpt  String           --    an un-recognized option-   | NonOpt    String           --    a non-option-   | EndOfOpts                  --    end-of-options marker (i.e. "--")-   | OptErr    String           --    something went wrong...---- | Return a string describing the usage of a command, derived from--- the header (first argument) and the options described by the --- second argument.-usageInfo :: String                    -- header-          -> [OptDescr a]              -- option descriptors-          -> String                    -- nicely formatted description of options-usageInfo header optDescr = unlines (header:table)-   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr-         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds-         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z-         sameLen xs     = flushLeft ((maximum . map length) xs) xs-         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]--fmtOpt :: OptDescr a -> [(String,String,String)]-fmtOpt (Option sos los ad descr) =-   case lines descr of-     []     -> [(sosFmt,losFmt,"")]-     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]-   where sepBy _  []     = ""-         sepBy _  [x]    = x-         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs-         sosFmt = sepBy ',' (map (fmtShort ad) sos)-         losFmt = sepBy ',' (map (fmtLong  ad) los)--fmtShort :: ArgDescr a -> Char -> String-fmtShort (NoArg  _   ) so = "-" ++ [so]-fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad-fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"--fmtLong :: ArgDescr a -> String -> String-fmtLong (NoArg  _   ) lo = "--" ++ lo-fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad-fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"--{-|-Process the command-line, and return the list of values that matched-(and those that didn\'t). The arguments are:--* The order requirements (see 'ArgOrder')--* The option descriptions (see 'OptDescr')--* The actual command line arguments (presumably got from -  'System.Environment.getArgs').--'getOpt' returns a triple consisting of the option arguments, a list-of non-options, and a list of error messages.--}-getOpt :: ArgOrder a                   -- non-option handling-       -> [OptDescr a]                 -- option descriptors-       -> [String]                     -- the command-line arguments-       -> ([a],[String],[String])      -- (options,non-options,error messages)-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)-   where (os,xs,us,es) = getOpt' ordering optDescr args--{-|-This is almost the same as 'getOpt', but returns a quadruple-consisting of the option arguments, a list of non-options, a list of-unrecognized options, and a list of error messages.--}-getOpt' :: ArgOrder a                         -- non-option handling-        -> [OptDescr a]                       -- option descriptors-        -> [String]                           -- the command-line arguments-        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)-getOpt' _        _        []         =  ([],[],[],[])-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering-   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)-         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)-         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])-         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)-         procNextOpt (NonOpt x)   (ReturnInOrder f) = (f x :os, xs,us,es)-         procNextOpt EndOfOpts    RequireOrder      = ([],rest,[],[])-         procNextOpt EndOfOpts    Permute           = ([],rest,[],[])-         procNextOpt EndOfOpts    (ReturnInOrder f) = (map f rest,[],[],[])-         procNextOpt (OptErr e)   _                 = (os,xs,us,e:es)--         (opt,rest) = getNext arg args optDescr-         (os,xs,us,es) = getOpt' ordering optDescr rest---- take a look at the next cmd line arg and decide what to do with it-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])-getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr-getNext a            rest _        = (NonOpt a,rest)---- handle long option-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])-longOpt ls rs optDescr = long ads arg rs-   where (opt,arg) = break (=='=') ls-         getWith p = [ o | o@(Option _ xs _ _) <- optDescr-                         , find (p opt) xs /= Nothing ]-         exact     = getWith (==)-         options   = if null exact then getWith isPrefixOf else exact-         ads       = [ ad | Option _ _ ad _ <- options ]-         optStr    = ("--"++opt)--         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)-         long [NoArg  a  ] []       rest     = (Opt a,rest)-         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)-         long [ReqArg _ d] []       []       = (errReq d optStr,[])-         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)-         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)-         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)-         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)-         long _            _        rest     = (UnreqOpt ("--"++ls),rest)---- handle short option-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])-shortOpt y ys rs optDescr = short ads ys rs-  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]-        ads     = [ ad | Option _ _ ad _ <- options ]-        optStr  = '-':[y]--        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)-        short (NoArg  a  :_) [] rest     = (Opt a,rest)-        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)-        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])-        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)-        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)-        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)-        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)-        short []             [] rest     = (UnreqOpt optStr,rest)-        short []             xs rest     = (UnreqOpt optStr,('-':xs):rest)---- miscellaneous error formatting--errAmbig :: [OptDescr a] -> String -> OptKind a-errAmbig ods optStr = OptErr (usageInfo header ods)-   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"--errReq :: String -> String -> OptKind a-errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")--errUnrec :: String -> String-errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"--errNoArg :: String -> OptKind a-errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")--{---------------------------------------------------------------------------------------------- and here a small and hopefully enlightening example:--data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show--options :: [OptDescr Flag]-options =-   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",-    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",-    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",-    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]--out :: Maybe String -> Flag-out Nothing  = Output "stdout"-out (Just o) = Output o--test :: ArgOrder Flag -> [String] -> String-test order cmdline = case getOpt order options cmdline of-                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"-                        (_,_,errs) -> concat errs ++ usageInfo header options-   where header = "Usage: foobar [OPTION...] files..."---- example runs:--- putStr (test RequireOrder ["foo","-v"])---    ==> options=[]  args=["foo", "-v"]--- putStr (test Permute ["foo","-v"])---    ==> options=[Verbose]  args=["foo"]--- putStr (test (ReturnInOrder Arg) ["foo","-v"])---    ==> options=[Arg "foo", Verbose]  args=[]--- putStr (test Permute ["foo","--","-v"])---    ==> options=[]  args=["foo", "-v"]--- putStr (test Permute ["-?o","--name","bar","--na=baz"])---    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]--- putStr (test Permute ["--ver","foo"])---    ==> option `--ver' is ambiguous; could be one of:---          -v      --verbose             verbosely list files---          -V, -?  --version, --release  show version info   ---        Usage: foobar [OPTION...] files...---          -v        --verbose             verbosely list files  ---          -V, -?    --version, --release  show version info     ---          -o[FILE]  --output[=FILE]       use FILE for dump     ---          -n USER   --name=USER           only dump USER's files--------------------------------------------------------------------------------------------}--{- $example1--A simple choice for the type associated with flags is to define a type-@Flag@ as an algebraic type representing the possible flags and their-arguments:-->    module Opts1 where->    ->    import System.Console.GetOpt->    import Data.Maybe ( fromMaybe )->    ->    data Flag ->     = Verbose  | Version ->     | Input String | Output String | LibDir String->       deriving Show->    ->    options :: [OptDescr Flag]->    options =->     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"->     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"->     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"->     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"->     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"->     ]->    ->    inp,outp :: Maybe String -> Flag->    outp = Output . fromMaybe "stdout"->    inp  = Input  . fromMaybe "stdin"->    ->    compilerOpts :: [String] -> IO ([Flag], [String])->    compilerOpts argv = ->       case getOpt Permute options argv of->          (o,n,[]  ) -> return (o,n)->          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))->      where header = "Usage: ic [OPTION...] files..."--Then the rest of the program will use the constructed list of flags-to determine it\'s behaviour.---}--{- $example2--A different approach is to group the option values in a record of type-@Options@, and have each flag yield a function of type-@Options -> Options@ transforming this record.-->    module Opts2 where->->    import System.Console.GetOpt->    import Data.Maybe ( fromMaybe )->->    data Options = Options->     { optVerbose     :: Bool->     , optShowVersion :: Bool->     , optOutput      :: Maybe FilePath->     , optInput       :: Maybe FilePath->     , optLibDirs     :: [FilePath]->     } deriving Show->->    defaultOptions    = Options->     { optVerbose     = False->     , optShowVersion = False->     , optOutput      = Nothing->     , optInput       = Nothing->     , optLibDirs     = []->     }->->    options :: [OptDescr (Options -> Options)]->    options =->     [ Option ['v']     ["verbose"]->         (NoArg (\ opts -> opts { optVerbose = True }))->         "chatty output on stderr"->     , Option ['V','?'] ["version"]->         (NoArg (\ opts -> opts { optShowVersion = True }))->         "show version number"->     , Option ['o']     ["output"]->         (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")->                 "FILE")->         "output FILE"->     , Option ['c']     []->         (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")->                 "FILE")->         "input FILE"->     , Option ['L']     ["libdir"]->         (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")->         "library directory"->     ]->->    compilerOpts :: [String] -> IO (Options, [String])->    compilerOpts argv =->       case getOpt Permute options argv of->          (o,n,[]  ) -> return (foldl (flip id) defaultOptions o, n)->          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))->      where header = "Usage: ic [OPTION...] files..."--Similarly, each flag could yield a monadic function transforming a record,-of type @Options -> IO Options@ (or any other monad), allowing option-processing to perform actions of the chosen monad, e.g. printing help or-version messages, checking that file arguments exist, etc.---}-
− System/Environment.hs 
@@ -1,377 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  System.Environment--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Miscellaneous information about the system environment.-----------------------------------------------------------------------------------module System.Environment-    (-      getArgs,-      getProgName,-      getExecutablePath,-      getEnv,-      lookupEnv,-      setEnv,-      unsetEnv,-      withArgs,-      withProgName,-      getEnvironment,-  ) where--import Foreign-import Foreign.C-import System.IO.Error (mkIOError)-import Control.Exception.Base (bracket_, throwIO)-#if defined(mingw32_HOST_OS)-import Control.Exception.Base (bracket)-#endif--- import GHC.IO-import GHC.IO.Exception-import qualified GHC.Foreign as GHC-import Control.Monad-#if defined(mingw32_HOST_OS)-import GHC.IO.Encoding (argvEncoding)-import GHC.Windows-#else-import GHC.IO.Encoding (getFileSystemEncoding, argvEncoding)-import System.Posix.Internals (withFilePath)-#endif--import System.Environment.ExecutablePath--#if defined(mingw32_HOST_OS)-# if defined(i386_HOST_ARCH)-#  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-#  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif-#endif--#include "HsBaseConfig.h"---- ------------------------------------------------------------------------------ getArgs, getProgName, getEnv---- | Computation 'getArgs' returns a list of the program's command--- line arguments (not including the program name).-getArgs :: IO [String]-getArgs =-  alloca $ \ p_argc ->-  alloca $ \ p_argv -> do-   getProgArgv p_argc p_argv-   p    <- fromIntegral `liftM` peek p_argc-   argv <- peek p_argv-   enc <- argvEncoding-   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)---foreign import ccall unsafe "getProgArgv"-  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()--{-|-Computation 'getProgName' returns the name of the program as it was-invoked.--However, this is hard-to-impossible to implement on some non-Unix-OSes, so instead, for maximum portability, we just return the leafname-of the program as invoked. Even then there are some differences-between platforms: on Windows, for example, a program invoked as foo-is probably really @FOO.EXE@, and that is what 'getProgName' will return.--}-getProgName :: IO String--- Ignore the arguments to hs_init on Windows for the sake of Unicode compat-getProgName =-  alloca $ \ p_argc ->-  alloca $ \ p_argv -> do-     getProgArgv p_argc p_argv-     argv <- peek p_argv-     unpackProgName argv--unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]-unpackProgName argv = do-  enc <- argvEncoding-  s <- peekElemOff argv 0 >>= GHC.peekCString enc-  return (basename s)--basename :: FilePath -> FilePath-basename f = go f f- where-  go acc [] = acc-  go acc (x:xs)-    | isPathSeparator x = go xs xs-    | otherwise         = go acc xs--  isPathSeparator :: Char -> Bool-  isPathSeparator '/'  = True-#if defined(mingw32_HOST_OS)-  isPathSeparator '\\' = True-#endif-  isPathSeparator _    = False----- | Computation 'getEnv' @var@ returns the value--- of the environment variable @var@. For the inverse, the--- `System.Environment.setEnv` function can be used.------ This computation may fail with:------  * 'System.IO.Error.isDoesNotExistError' if the environment variable---    does not exist.--getEnv :: String -> IO String-getEnv name = lookupEnv name >>= maybe handleError return-  where-#if defined(mingw32_HOST_OS)-    handleError = do-        err <- c_GetLastError-        if err == eRROR_ENVVAR_NOT_FOUND-            then ioe_missingEnvVar name-            else throwGetLastError "getEnv"--eRROR_ENVVAR_NOT_FOUND :: DWORD-eRROR_ENVVAR_NOT_FOUND = 203--foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"-  c_GetLastError:: IO DWORD--#else-    handleError = ioe_missingEnvVar name-#endif---- | Return the value of the environment variable @var@, or @Nothing@ if--- there is no such value.------ For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.------ @since 4.6.0.0-lookupEnv :: String -> IO (Maybe String)-#if defined(mingw32_HOST_OS)-lookupEnv name = withCWString name $ \s -> try_size s 256-  where-    try_size s size = allocaArray (fromIntegral size) $ \p_value -> do-      res <- c_GetEnvironmentVariable s p_value size-      case res of-        0 -> return Nothing-        _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable-          | otherwise  -> peekCWString p_value >>= return . Just--foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"-  c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD-#else-lookupEnv name =-    withCString name $ \s -> do-      litstring <- c_getenv s-      if litstring /= nullPtr-        then do enc <- getFileSystemEncoding-                result <- GHC.peekCString enc litstring-                return $ Just result-        else return Nothing--foreign import ccall unsafe "getenv"-   c_getenv :: CString -> IO (Ptr CChar)-#endif--ioe_missingEnvVar :: String -> IO a-ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"-    "no environment variable" Nothing (Just name))---- | @setEnv name value@ sets the specified environment variable to @value@.------ Early versions of this function operated under the mistaken belief that--- setting an environment variable to the /empty string/ on Windows removes--- that environment variable from the environment.  For the sake of--- compatibility, it adopted that behavior on POSIX.  In particular------ @--- setEnv name \"\"--- @------ has the same effect as------ @--- `unsetEnv` name--- @------ If you'd like to be able to set environment variables to blank strings,--- use `System.Environment.Blank.setEnv`.------ Throws `Control.Exception.IOException` if @name@ is the empty string or--- contains an equals sign.------ @since 4.7.0.0-setEnv :: String -> String -> IO ()-setEnv key_ value_-  | null key       = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)-  | '=' `elem` key = throwIO (mkIOError InvalidArgument "setEnv" Nothing Nothing)-  | null value     = unsetEnv key-  | otherwise      = setEnv_ key value-  where-    key   = takeWhile (/= '\NUL') key_-    value = takeWhile (/= '\NUL') value_--setEnv_ :: String -> String -> IO ()-#if defined(mingw32_HOST_OS)-setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do-  success <- c_SetEnvironmentVariable k v-  unless success (throwGetLastError "setEnv")--foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"-  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool-#else---- NOTE: The 'setenv()' function is not available on all systems, hence we use--- 'putenv()'.  This leaks memory, but so do common implementations of--- 'setenv()' (AFAIK).-setEnv_ k v = putEnv (k ++ "=" ++ v)--putEnv :: String -> IO ()-putEnv keyvalue = do-  s <- getFileSystemEncoding >>= (`GHC.newCString` keyvalue)-  -- IMPORTANT: Do not free `s` after calling putenv!-  ---  -- According to SUSv2, the string passed to putenv becomes part of the-  -- environment.-  throwErrnoIf_ (/= 0) "putenv" (c_putenv s)--foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt-#endif---- | @unsetEnv name@ removes the specified environment variable from the--- environment of the current process.------ Throws `Control.Exception.IOException` if @name@ is the empty string or--- contains an equals sign.------ @since 4.7.0.0-unsetEnv :: String -> IO ()-#if defined(mingw32_HOST_OS)-unsetEnv key = withCWString key $ \k -> do-  success <- c_SetEnvironmentVariable k nullPtr-  unless success $ do-    -- We consider unsetting an environment variable that does not exist not as-    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.-    err <- c_GetLastError-    unless (err == eRROR_ENVVAR_NOT_FOUND) $ do-      throwGetLastError "unsetEnv"-#else--#if defined(HAVE_UNSETENV)-unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)-foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt-#else-unsetEnv key = setEnv_ key ""-#endif--#endif--{-|-'withArgs' @args act@ - while executing action @act@, have 'getArgs'-return @args@.--}-withArgs :: [String] -> IO a -> IO a-withArgs xs act = do-   p <- System.Environment.getProgName-   withArgv (p:xs) act--{-|-'withProgName' @name act@ - while executing action @act@,-have 'getProgName' return @name@.--}-withProgName :: String -> IO a -> IO a-withProgName nm act = do-   xs <- System.Environment.getArgs-   withArgv (nm:xs) act---- Worker routine which marshals and replaces an argv vector for--- the duration of an action.--withArgv :: [String] -> IO a -> IO a-withArgv = withProgArgv--withProgArgv :: [String] -> IO a -> IO a-withProgArgv new_args act = do-  pName <- System.Environment.getProgName-  existing_args <- System.Environment.getArgs-  bracket_ (setProgArgv new_args)-           (setProgArgv (pName:existing_args))-           act--setProgArgv :: [String] -> IO ()-setProgArgv argv = do-  enc <- argvEncoding-  GHC.withCStringsLen enc argv $ \len css ->-    c_setProgArgv (fromIntegral len) css---- setProgArgv copies the arguments-foreign import ccall unsafe "setProgArgv"-  c_setProgArgv  :: CInt -> Ptr CString -> IO ()---- |'getEnvironment' retrieves the entire environment as a--- list of @(key,value)@ pairs.------ If an environment entry does not contain an @\'=\'@ character,--- the @key@ is the whole entry and the @value@ is the empty string.-getEnvironment :: IO [(String, String)]--#if defined(mingw32_HOST_OS)-getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock ->-    if pBlock == nullPtr then return []-     else go pBlock-  where-    go pBlock = do-        -- The block is terminated by a null byte where there-        -- should be an environment variable of the form X=Y-        c <- peek pBlock-        if c == 0 then return []-         else do-          -- Seek the next pair (or terminating null):-          pBlock' <- seekNull pBlock False-          -- We now know the length in bytes, but ignore it when-          -- getting the actual String:-          str <- peekCWString pBlock-          fmap (divvy str :) $ go pBlock'--    -- Returns pointer to the byte *after* the next null-    seekNull pBlock done = do-        let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar)-        if done then return pBlock'-         else do-           c <- peek pBlock'-           seekNull pBlock' (c == (0 :: Word8 ))--foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentStringsW"-  c_GetEnvironmentStrings :: IO (Ptr CWchar)--foreign import WINDOWS_CCONV unsafe "windows.h FreeEnvironmentStringsW"-  c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool-#else-getEnvironment = do-   pBlock <- getEnvBlock-   if pBlock == nullPtr then return []-    else do-      enc <- getFileSystemEncoding-      stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString enc)-      return (map divvy stuff)--foreign import ccall unsafe "__hscore_environ"-  getEnvBlock :: IO (Ptr CString)-#endif--divvy :: String -> (String, String)-divvy str =-  case break (=='=') str of-    (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)-    (name,_:value) -> (name,value)
− System/Environment/Blank.hsc 
@@ -1,193 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE CApiFFI #-}---------------------------------------------------------------------------------- |--- Module      :  System.Environment.Blank--- Copyright   :  (c) Habib Alamin 2017--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ A setEnv implementation that allows blank environment variables. Mimics--- the `System.Posix.Env` module from the @unix@ package, but with support--- for Windows too.------ The matrix of platforms that:------   * support @putenv("FOO")@ to unset environment variables,---   * support @putenv("FOO=")@ to unset environment variables or set them---     to blank values,---   * support @unsetenv@ to unset environment variables,---   * support @setenv@ to set environment variables,---   * etc.------ is very complicated. Some platforms don't support unsetting of environment--- variables at all.-----------------------------------------------------------------------------------module System.Environment.Blank-    (-      module System.Environment,-      getEnv,-      getEnvDefault,-      setEnv,-      unsetEnv,-  ) where--import Foreign.C-#if defined(mingw32_HOST_OS)-import Foreign.Ptr-import GHC.Windows-import Control.Monad-#else-import System.Posix.Internals-#endif-import GHC.IO.Exception-import System.IO.Error-import Control.Exception.Base-import Data.Maybe--import System.Environment-    (-      getArgs,-      getProgName,-      getExecutablePath,-      withArgs,-      withProgName,-      getEnvironment-  )-#if !defined(mingw32_HOST_OS)-import qualified System.Environment as Environment-#endif---- TODO: include windows_cconv.h when it's merged, instead of duplicating--- this C macro block.-#if defined(mingw32_HOST_OS)-# if defined(i386_HOST_ARCH)-##  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-##  define WINDOWS_CCONV ccall-# else-##  error Unknown mingw32 arch-# endif-#endif--#include "HsBaseConfig.h"--throwInvalidArgument :: String -> IO a-throwInvalidArgument from =-  throwIO (mkIOError InvalidArgument from Nothing Nothing)---- | Similar to 'System.Environment.lookupEnv'.-getEnv :: String -> IO (Maybe String)-#if defined(mingw32_HOST_OS)-getEnv = (<$> getEnvironment) . lookup-#else-getEnv = Environment.lookupEnv-#endif---- | Get an environment value or a default value.-getEnvDefault ::-  String    {- ^ variable name                    -} ->-  String    {- ^ fallback value                   -} ->-  IO String {- ^ variable value or fallback value -}-getEnvDefault name fallback = fromMaybe fallback <$> getEnv name---- | Like 'System.Environment.setEnv', but allows blank environment values--- and mimics the function signature of 'System.Posix.Env.setEnv' from the--- @unix@ package.-setEnv ::-  String {- ^ variable name  -} ->-  String {- ^ variable value -} ->-  Bool   {- ^ overwrite      -} ->-  IO ()-setEnv key_ value_ overwrite-  | null key       = throwInvalidArgument "setEnv"-  | '=' `elem` key = throwInvalidArgument "setEnv"-  | otherwise      =-    if overwrite-    then setEnv_ key value-    else do-      env_var <- getEnv key-      case env_var of-          Just _  -> return ()-          Nothing -> setEnv_ key value-  where-    key   = takeWhile (/= '\NUL') key_-    value = takeWhile (/= '\NUL') value_--setEnv_ :: String -> String -> IO ()-#if defined(mingw32_HOST_OS)-setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do-  success <- c_SetEnvironmentVariable k v-  unless success (throwGetLastError "setEnv")--foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"-  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool-#else-setEnv_ key value =-  withFilePath key $ \ keyP ->-    withFilePath value $ \ valueP ->-      throwErrnoIfMinus1_ "setenv" $-        c_setenv keyP valueP (fromIntegral (fromEnum True))--foreign import ccall unsafe "setenv"-   c_setenv :: CString -> CString -> CInt -> IO CInt-#endif---- | Like 'System.Environment.unsetEnv', but allows for the removal of--- blank environment variables. May throw an exception if the underlying--- platform doesn't support unsetting of environment variables.-unsetEnv :: String -> IO ()-#if defined(mingw32_HOST_OS)-unsetEnv key = withCWString key $ \k -> do-  success <- c_SetEnvironmentVariable k nullPtr-  unless success $ do-    -- We consider unsetting an environment variable that does not exist not as-    -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND.-    err <- c_GetLastError-    unless (err == eRROR_ENVVAR_NOT_FOUND) $ do-      throwGetLastError "unsetEnv"--eRROR_ENVVAR_NOT_FOUND :: DWORD-eRROR_ENVVAR_NOT_FOUND = 203--foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"-  c_GetLastError:: IO DWORD-#elif HAVE_UNSETENV-# if !UNSETENV_RETURNS_VOID-unsetEnv name = withFilePath name $ \ s ->-  throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s)---- POSIX.1-2001 compliant unsetenv(3)-foreign import capi unsafe "HsBase.h unsetenv"-   c_unsetenv :: CString -> IO CInt-# else-unsetEnv name = withFilePath name c_unsetenv---- pre-POSIX unsetenv(3) returning @void@-foreign import capi unsafe "HsBase.h unsetenv"-   c_unsetenv :: CString -> IO ()-# endif-#else-unsetEnv name =-  if '=' `elem` name-  then throwInvalidArgument "unsetEnv"-  else putEnv name--putEnv :: String -> IO ()-putEnv keyvalue = do-  s <- getFileSystemEncoding >>= (`newCString` keyvalue)-  -- IMPORTANT: Do not free `s` after calling putenv!-  ---  -- According to SUSv2, the string passed to putenv becomes part of the-  -- environment. #7342-  throwErrnoIf_ (/= 0) "putenv" (c_putenv s)--foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt-#endif
− System/Environment/ExecutablePath.hsc 
@@ -1,299 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  System.Environment.ExecutablePath--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Function to retrieve the absolute filepath of the current executable.------ @since 4.6.0.0--------------------------------------------------------------------------------module System.Environment.ExecutablePath ( getExecutablePath ) where---- The imports are purposely kept completely disjoint to prevent edits--- to one OS implementation from breaking another.--#if defined(darwin_HOST_OS)-import Data.Word-import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Ptr-import Foreign.Storable-import System.Posix.Internals-#elif defined(linux_HOST_OS)-import Foreign.C-import Foreign.Marshal.Array-import System.Posix.Internals-#elif defined(freebsd_HOST_OS)-import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Ptr-import Foreign.Storable-import System.Posix.Internals-#include <sys/types.h>-#include <sys/sysctl.h>-#elif defined(mingw32_HOST_OS)-import Control.Exception-import Data.List (isPrefixOf)-import Data.Word-import Foreign.C-import Foreign.Marshal.Array-import Foreign.Ptr-#include <windows.h>-#include <stdint.h>-#else-import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Ptr-import Foreign.Storable-import System.Posix.Internals-#endif---- The exported function is defined outside any if-guard to make sure--- every OS implements it with the same type.---- | Returns the absolute pathname of the current executable.------ Note that for scripts and interactive sessions, this is the path to--- the interpreter (e.g. ghci.)------ Since base 4.11.0.0, 'getExecutablePath' resolves symlinks on Windows.--- If an executable is launched through a symlink, 'getExecutablePath'--- returns the absolute path of the original executable.------ @since 4.6.0.0-getExecutablePath :: IO FilePath------------------------------------------------------------------------------------- Mac OS X--#if defined(darwin_HOST_OS)--type UInt32 = Word32--foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"-    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt---- | Returns the path of the main executable. The path may be a--- symbolic link and not the real file.------ See dyld(3)-_NSGetExecutablePath :: IO FilePath-_NSGetExecutablePath =-    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X-    alloca $ \ bufsize -> do-        poke bufsize 1024-        status <- c__NSGetExecutablePath buf bufsize-        if status == 0-            then peekFilePath buf-            else do reqBufsize <- fromIntegral `fmap` peek bufsize-                    allocaBytes reqBufsize $ \ newBuf -> do-                        status2 <- c__NSGetExecutablePath newBuf bufsize-                        if status2 == 0-                             then peekFilePath newBuf-                             else errorWithoutStackTrace "_NSGetExecutablePath: buffer too small"--foreign import ccall unsafe "stdlib.h realpath"-    c_realpath :: CString -> CString -> IO CString---- | Resolves all symbolic links, extra \/ characters, and references--- to \/.\/ and \/..\/. Returns an absolute pathname.------ See realpath(3)-realpath :: FilePath -> IO FilePath-realpath path =-    withFilePath path $ \ fileName ->-    allocaBytes 1024 $ \ resolvedName -> do-        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName-        peekFilePath resolvedName--getExecutablePath = _NSGetExecutablePath >>= realpath------------------------------------------------------------------------------------- Linux--#elif defined(linux_HOST_OS)--foreign import ccall unsafe "readlink"-    c_readlink :: CString -> CString -> CSize -> IO CInt---- | Reads the @FilePath@ pointed to by the symbolic link and returns--- it.------ See readlink(2)-readSymbolicLink :: FilePath -> IO FilePath-readSymbolicLink file =-    allocaArray0 4096 $ \buf ->-        withFilePath file $ \s -> do-            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $-                   c_readlink s buf 4096-            peekFilePathLen (buf,fromIntegral len)--getExecutablePath = readSymbolicLink $ "/proc/self/exe"------------------------------------------------------------------------------------- FreeBSD--#elif defined(freebsd_HOST_OS)--foreign import ccall unsafe "sysctl"-  c_sysctl-    :: Ptr CInt   -- MIB-    -> CUInt      -- MIB size-    -> Ptr CChar  -- old / current value buffer-    -> Ptr CSize  -- old / current value buffer size-    -> Ptr CChar  -- new value-    -> CSize      -- new value size-    -> IO CInt    -- result--getExecutablePath = do-  withArrayLen mib $ \n mibPtr -> do-    let mibLen = fromIntegral n-    alloca $ \bufSizePtr -> do-      status <- c_sysctl mibPtr mibLen nullPtr bufSizePtr nullPtr 0-      case status of-        0 -> do-          reqBufSize <- fromIntegral <$> peek bufSizePtr-          allocaBytes reqBufSize $ \buf -> do-            newStatus <- c_sysctl mibPtr mibLen buf bufSizePtr nullPtr 0-            case newStatus of-              0 -> peekFilePath buf-              _ -> barf-        _ -> barf-  where-    barf = throwErrno "getExecutablePath"-    mib =-      [ (#const CTL_KERN)-      , (#const KERN_PROC)-      , (#const KERN_PROC_PATHNAME)-      , -1   -- current process-      ]-------------------------------------------------------------------------------------- Windows--#elif defined(mingw32_HOST_OS)--# if defined(i386_HOST_ARCH)-##  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-##  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif--getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32-  where-    go size = allocaArray (fromIntegral size) $ \ buf -> do-        ret <- c_GetModuleFileName nullPtr buf size-        case ret of-            0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error"-            _ | ret < size -> do-                  path <- peekCWString buf-                  real <- getFinalPath path-                  exists <- withCWString real c_pathFileExists-                  if exists-                    then return real-                    else fail path-              | otherwise  -> go (size * 2)---- | Returns the final path of the given path. If the given---   path is a symbolic link, the returned value is the---   path the (possibly chain of) symbolic link(s) points to.---   Otherwise, the original path is returned, even when the filepath---   is incorrect.------ Adapted from:--- https://msdn.microsoft.com/en-us/library/windows/desktop/aa364962.aspx-getFinalPath :: FilePath -> IO FilePath-getFinalPath path = withCWString path $ \s ->-  bracket (createFile s) c_closeHandle $ \h -> do-    let invalid = h == wordPtrToPtr (#const (intptr_t)INVALID_HANDLE_VALUE)-    if invalid then pure path else go h bufSize--  where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do-          ret <- c_getFinalPathHandle h outPath sz (#const FILE_NAME_OPENED)-          if ret < sz-            then sanitize . rejectUNCPath <$> peekCWString outPath-            else go h (2 * sz)--        sanitize s-          | "\\\\?\\" `isPrefixOf` s = drop 4 s-          | otherwise                = s--        -- see https://gitlab.haskell.org/ghc/ghc/issues/14460-        rejectUNCPath s-          | "\\\\?\\UNC\\" `isPrefixOf` s = path-          | otherwise                     = s--        -- the initial size of the buffer in which we store the-        -- final path; if this is not enough, we try with a buffer of-        -- size 2^k * bufSize, for k = 1, 2, 3, ... until the buffer-        -- is large enough.-        bufSize = 1024--foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"-    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32--foreign import WINDOWS_CCONV unsafe "windows.h PathFileExistsW"-    c_pathFileExists :: CWString -> IO Bool--foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW"-    c_createFile :: CWString-                 -> Word32-                 -> Word32-                 -> Ptr ()-                 -> Word32-                 -> Word32-                 -> Ptr ()-                 -> IO (Ptr ())--createFile :: CWString -> IO (Ptr ())-createFile file =-  c_createFile file (#const GENERIC_READ)-                    (#const FILE_SHARE_READ)-                    nullPtr-                    (#const OPEN_EXISTING)-                    (#const FILE_ATTRIBUTE_NORMAL)-                    nullPtr--foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"-  c_closeHandle  :: Ptr () -> IO Bool--foreign import WINDOWS_CCONV unsafe "windows.h GetFinalPathNameByHandleW"-  c_getFinalPathHandle :: Ptr () -> CWString -> Word32 -> Word32 -> IO Word32------------------------------------------------------------------------------------- Fallback to argv[0]--#else--foreign import ccall unsafe "getFullProgArgv"-    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()--getExecutablePath =-    alloca $ \ p_argc ->-    alloca $ \ p_argv -> do-        c_getFullProgArgv p_argc p_argv-        argc <- peek p_argc-        if argc > 0-            -- 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 errorWithoutStackTrace $ "getExecutablePath: " ++ msg-  where msg = "no OS specific implementation and program name couldn't be " ++-              "found in argv"------------------------------------------------------------------------------------#endif
− System/Exit.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  System.Exit--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Exiting the program.-----------------------------------------------------------------------------------module System.Exit-    (-      ExitCode(ExitSuccess,ExitFailure)-    , exitWith-    , exitFailure-    , exitSuccess-    , die-  ) where--import System.IO--import GHC.IO-import GHC.IO.Exception---- ------------------------------------------------------------------------------ exitWith---- | Computation 'exitWith' @code@ throws 'ExitCode' @code@.--- Normally this terminates the program, returning @code@ to the--- program's caller.------ On program termination, the standard 'Handle's 'stdout' and--- 'stderr' are flushed automatically; any other buffered 'Handle's--- need to be flushed manually, otherwise the buffered data will be--- discarded.------ A program that fails in any other way is treated as if it had--- called 'exitFailure'.--- A program that terminates successfully without calling 'exitWith'--- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'.------ As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses--- the error handling in the 'IO' monad and cannot be intercepted by--- 'catch' from the "Prelude".  However it is a 'Control.Exception.SomeException', and can--- be caught using the functions of "Control.Exception".  This means--- that cleanup computations added with 'Control.Exception.bracket'--- (from "Control.Exception") are also executed properly on 'exitWith'.------ Note: in GHC, 'exitWith' should be called from the main program--- thread in order to exit the process.  When called from another--- thread, 'exitWith' will throw an 'ExitException' as normal, but the--- exception will not cause the process itself to exit.----exitWith :: ExitCode -> IO a-exitWith ExitSuccess = throwIO ExitSuccess-exitWith code@(ExitFailure n)-  | n /= 0 = throwIO code-  | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing)---- | The computation 'exitFailure' is equivalent to--- 'exitWith' @(@'ExitFailure' /exitfail/@)@,--- where /exitfail/ is implementation-dependent.-exitFailure :: IO a-exitFailure = exitWith (ExitFailure 1)---- | The computation 'exitSuccess' is equivalent to--- 'exitWith' 'ExitSuccess', It terminates the program--- successfully.-exitSuccess :: IO a-exitSuccess = exitWith ExitSuccess---- | Write given error message to `stderr` and terminate with `exitFailure`.------ @since 4.8.0.0-die :: String -> IO a-die err = hPutStrLn stderr err >> exitFailure
− System/IO.hs 
@@ -1,689 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}---------------------------------------------------------------------------------- |--- Module      :  System.IO--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  stable--- Portability :  portable------ The standard IO library.-----------------------------------------------------------------------------------module System.IO (-    -- * The IO monad--    IO,-    fixIO,--    -- * Files and handles--    FilePath,--    Handle,             -- abstract, instance of: Eq, Show.--    -- | GHC note: a 'Handle' will be automatically closed when the garbage-    -- collector detects that it has become unreferenced by the program.-    -- However, relying on this behaviour is not generally recommended:-    -- the garbage collector is unpredictable.  If possible, use-    -- an explicit 'hClose' to close 'Handle's when they are no longer-    -- required.  GHC does not currently attempt to free up file-    -- descriptors when they have run out, it is your responsibility to-    -- ensure that this doesn't happen.--    -- ** Standard handles--    -- | Three handles are allocated during program initialisation,-    -- and are initially open.--    stdin, stdout, stderr,--    -- * Opening and closing files--    -- ** Opening files--    withFile,-    openFile,-    IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),--    -- ** Closing files--    hClose,--    -- ** Special cases--    -- | These functions are also exported by the "Prelude".--    readFile,-    readFile',-    writeFile,-    appendFile,--    -- ** File locking--    -- $locking--    -- * Operations on handles--    -- ** Determining and changing the size of a file--    hFileSize,-    hSetFileSize,--    -- ** Detecting the end of input--    hIsEOF,-    isEOF,--    -- ** Buffering operations--    BufferMode(NoBuffering,LineBuffering,BlockBuffering),-    hSetBuffering,-    hGetBuffering,-    hFlush,--    -- ** Repositioning handles--    hGetPosn,-    hSetPosn,-    HandlePosn,                -- abstract, instance of: Eq, Show.--    hSeek,-    SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),-    hTell,--    -- ** Handle properties--    hIsOpen, hIsClosed,-    hIsReadable, hIsWritable,-    hIsSeekable,--    -- ** Terminal operations (not portable: GHC only)--    hIsTerminalDevice,--    hSetEcho,-    hGetEcho,--    -- ** Showing handle state (not portable: GHC only)--    hShow,--    -- * Text input and output--    -- ** Text input--    hWaitForInput,-    hReady,-    hGetChar,-    hGetLine,-    hLookAhead,-    hGetContents,-    hGetContents',--    -- ** Text output--    hPutChar,-    hPutStr,-    hPutStrLn,-    hPrint,--    -- ** Special cases for standard input and output--    -- | These functions are also exported by the "Prelude".--    interact,-    putChar,-    putStr,-    putStrLn,-    print,-    getChar,-    getLine,-    getContents,-    getContents',-    readIO,-    readLn,--    -- * Binary input and output--    withBinaryFile,-    openBinaryFile,-    hSetBinaryMode,-    hPutBuf,-    hGetBuf,-    hGetBufSome,-    hPutBufNonBlocking,-    hGetBufNonBlocking,--    -- * Temporary files--    openTempFile,-    openBinaryTempFile,-    openTempFileWithDefaultPermissions,-    openBinaryTempFileWithDefaultPermissions,--    -- * Unicode encoding\/decoding--    -- | A text-mode 'Handle' has an associated 'TextEncoding', which-    -- is used to decode bytes into Unicode characters when reading,-    -- and encode Unicode characters into bytes when writing.-    ---    -- The default 'TextEncoding' is the same as the default encoding-    -- on your system, which is also available as 'localeEncoding'.-    -- (GHC note: on Windows, we currently do not support double-byte-    -- encodings; if the console\'s code page is unsupported, then-    -- 'localeEncoding' will be 'latin1'.)-    ---    -- Encoding and decoding errors are always detected and reported,-    -- except during lazy I/O ('hGetContents', 'getContents', and-    -- 'readFile'), where a decoding error merely results in-    -- termination of the character stream, as with other I/O errors.--    hSetEncoding,-    hGetEncoding,--    -- ** Unicode encodings-    TextEncoding,-    latin1,-    utf8, utf8_bom,-    utf16, utf16le, utf16be,-    utf32, utf32le, utf32be,-    localeEncoding,-    char8,-    mkTextEncoding,--    -- * Newline conversion--    -- | In Haskell, a newline is always represented by the character-    -- @\'\\n\'@.  However, in files and external character streams, a-    -- newline may be represented by another character sequence, such-    -- as @\'\\r\\n\'@.-    ---    -- A text-mode 'Handle' has an associated 'NewlineMode' that-    -- specifies how to translate newline characters.  The-    -- 'NewlineMode' specifies the input and output translation-    -- separately, so that for instance you can translate @\'\\r\\n\'@-    -- to @\'\\n\'@ on input, but leave newlines as @\'\\n\'@ on output.-    ---    -- The default 'NewlineMode' for a 'Handle' is-    -- 'nativeNewlineMode', which does no translation on Unix systems,-    -- but translates @\'\\r\\n\'@ to @\'\\n\'@ and back on Windows.-    ---    -- Binary-mode 'Handle's do no newline translation at all.-    ---    hSetNewlineMode,-    Newline(..), nativeNewline,-    NewlineMode(..),-    noNewlineTranslation, universalNewlineMode, nativeNewlineMode,-  ) where--import Control.Exception.Base--import Data.Bits-import Data.Maybe-import Foreign.C.Error-#if defined(mingw32_HOST_OS)-import Foreign.C.String-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils (with)-import Foreign.Storable-import GHC.IO.SubSystem-import GHC.IO.Windows.Handle (openFileAsTemp)-import GHC.IO.Handle.Windows (mkHandleFromHANDLE)-import GHC.IO.Device as IODevice-import GHC.Real (fromIntegral)-#endif-import Foreign.C.Types-import System.Posix.Internals-import System.Posix.Types--import GHC.Base-import GHC.List-#if !defined(mingw32_HOST_OS)-import GHC.IORef-#endif-import GHC.Num-import GHC.IO hiding ( bracket, onException )-import GHC.IO.IOMode-import qualified GHC.IO.FD as FD-import GHC.IO.Handle-import qualified GHC.IO.Handle.FD as POSIX-import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn )-import GHC.IO.Exception ( userError )-import GHC.IO.Encoding-import Text.Read-import GHC.IO.StdHandles-import GHC.Show-import GHC.MVar---- -------------------------------------------------------------------------------- Standard IO---- | Write a character to the standard output device--- (same as 'hPutChar' 'stdout').--putChar         :: Char -> IO ()-putChar c       =  hPutChar stdout c---- | Write a string to the standard output device--- (same as 'hPutStr' 'stdout').--putStr          :: String -> IO ()-putStr s        =  hPutStr stdout s---- | The same as 'putStr', but adds a newline character.--putStrLn        :: String -> IO ()-putStrLn s      =  hPutStrLn stdout s---- | The 'print' function outputs a value of any printable type to the--- standard output device.--- Printable types are those that are instances of class 'Show'; 'print'--- converts values to strings for output using the 'show' operation and--- adds a newline.------ For example, a program to print the first 20 integers and their--- powers of 2 could be written as:------ > main = print ([(n, 2^n) | n <- [0..19]])--print           :: Show a => a -> IO ()-print x         =  putStrLn (show x)---- | Read a character from the standard input device--- (same as 'hGetChar' 'stdin').--getChar         :: IO Char-getChar         =  hGetChar stdin---- | Read a line from the standard input device--- (same as 'hGetLine' 'stdin').--getLine         :: IO String-getLine         =  hGetLine stdin---- | The 'getContents' operation returns all user input as a single string,--- which is read lazily as it is needed--- (same as 'hGetContents' 'stdin').--getContents     :: IO String-getContents     =  hGetContents stdin---- | The 'getContents'' operation returns all user input as a single string,--- which is fully read before being returned--- (same as 'hGetContents'' 'stdin').------ @since 4.15.0.0--getContents'    :: IO String-getContents'    =  hGetContents' stdin---- | The 'interact' function takes a function of type @String->String@--- as its argument.  The entire input from the standard input device is--- passed to this function as its argument, and the resulting string is--- output on the standard output device.--interact        ::  (String -> String) -> IO ()-interact f      =   do s <- getContents-                       putStr (f s)---- | The 'readFile' function reads a file and--- returns the contents of the file as a string.--- The file is read lazily, on demand, as with 'getContents'.--readFile        :: FilePath -> IO String-readFile name   =  openFile name ReadMode >>= hGetContents---- | The 'readFile'' function reads a file and--- returns the contents of the file as a string.--- The file is fully read before being returned, as with 'getContents''.------ @since 4.15.0.0--readFile'       :: FilePath -> IO String--- There's a bit of overkill here—both withFile and--- hGetContents' will close the file in the end.-readFile' name  =  withFile name ReadMode hGetContents'---- | The computation 'writeFile' @file str@ function writes the string @str@,--- to the file @file@.-writeFile :: FilePath -> String -> IO ()-writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt)---- | The computation 'appendFile' @file str@ function appends the string @str@,--- to the file @file@.------ Note that 'writeFile' and 'appendFile' write a literal string--- to a file.  To write a value of any printable type, as with 'print',--- use the 'show' function to convert the value to a string first.------ > main = appendFile "squares" (show [(x,x*x) | x <- [0,0.1..2]])--appendFile      :: FilePath -> String -> IO ()-appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt)---- | The 'readLn' function combines 'getLine' and 'readIO'.--readLn :: Read a => IO a-readLn = getLine >>= readIO---- | The 'readIO' function is similar to 'read' except that it signals--- parse failure to the 'IO' monad instead of terminating the program.--readIO          :: Read a => String -> IO a-readIO s        =  case (do { (x,t) <- reads s ;-                              ("","") <- lex t ;-                              return x }) of-                        [x]    -> return x-                        []     -> ioError (userError "Prelude.readIO: no parse")-                        _      -> ioError (userError "Prelude.readIO: ambiguous parse")---- | The Unicode encoding of the current locale------ This is the initial locale encoding: if it has been subsequently changed by--- 'GHC.IO.Encoding.setLocaleEncoding' this value will not reflect that change.-localeEncoding :: TextEncoding-localeEncoding = initLocaleEncoding---- | Computation 'hReady' @hdl@ indicates whether at least one item is--- available for input from handle @hdl@.------ This operation may fail with:------  * 'System.IO.Error.isEOFError' if the end of file has been reached.--hReady          :: Handle -> IO Bool-hReady h        =  hWaitForInput h 0---- | Computation 'hPrint' @hdl t@ writes the string representation of @t@--- given by the 'shows' function to the file or channel managed by @hdl@--- and appends a newline.------ This operation may fail with:------  * 'System.IO.Error.isFullError' if the device is full; or------  * 'System.IO.Error.isPermissionError' if another system resource limit---    would be exceeded.--hPrint          :: Show a => Handle -> a -> IO ()-hPrint hdl      =  hPutStrLn hdl . show----- ------------------------------------------------------------------------------ fixIO---- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'. If the function--- passed to 'fixIO' inspects its argument, the resulting action will throw--- 'FixIOException'.-fixIO :: (a -> IO a) -> IO a-fixIO k = do-    m <- newEmptyMVar-    ans <- unsafeDupableInterleaveIO-             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->-                                    throwIO FixIOException)-    result <- k ans-    putMVar m result-    return result---- Note [Blackholing in fixIO]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~------ We do our own explicit black holing here, because GHC's lazy--- blackholing isn't enough.  In an infinite loop, GHC may run the IO--- computation a few times before it notices the loop, which is wrong.------ NOTE2: the explicit black-holing with an IORef ran into trouble--- with multiple threads (see #5421), so now we use an MVar. We used--- to use takeMVar with unsafeInterleaveIO. This, however, uses noDuplicate#,--- which is not particularly cheap. Better to use readMVar, which can be--- performed in multiple threads safely, and to use unsafeDupableInterleaveIO--- to avoid the noDuplicate cost.------ What we'd ideally want is probably an IVar, but we don't quite have those.--- STM TVars look like an option at first, but I don't think they are:--- we'd need to be able to write to the variable in an IO context, which can--- only be done using 'atomically', and 'atomically' is not allowed within--- unsafePerformIO. We can't know if someone will try to use the result--- of fixIO with unsafePerformIO!------ See also System.IO.Unsafe.unsafeFixIO.------- | The function creates a temporary file in ReadWrite mode.--- The created file isn\'t deleted automatically, so you need to delete it manually.------ The file is created with permissions such that only the current--- user can read\/write it.------ With some exceptions (see below), the file will be created securely--- in the sense that an attacker should not be able to cause--- openTempFile to overwrite another file on the filesystem using your--- credentials, by putting symbolic links (on Unix) in the place where--- the temporary file is to be created.  On Unix the @O_CREAT@ and--- @O_EXCL@ flags are used to prevent this attack, but note that--- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you--- rely on this behaviour it is best to use local filesystems only.----openTempFile :: FilePath   -- ^ Directory in which to create the file-             -> String     -- ^ File name template. If the template is \"foo.ext\" then-                           -- the created file will be \"fooXXX.ext\" where XXX is some-                           -- random number. Note that this should not contain any path-                           -- separator characters.-             -> IO (FilePath, Handle)-openTempFile tmp_dir template-    = openTempFile' "openTempFile" tmp_dir template False 0o600---- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.-openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)-openBinaryTempFile tmp_dir template-    = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600---- | Like 'openTempFile', but uses the default file permissions-openTempFileWithDefaultPermissions :: FilePath -> String-                                   -> IO (FilePath, Handle)-openTempFileWithDefaultPermissions tmp_dir template-    = openTempFile' "openTempFileWithDefaultPermissions" tmp_dir template False 0o666---- | Like 'openBinaryTempFile', but uses the default file permissions-openBinaryTempFileWithDefaultPermissions :: FilePath -> String-                                         -> IO (FilePath, Handle)-openBinaryTempFileWithDefaultPermissions tmp_dir template-    = openTempFile' "openBinaryTempFileWithDefaultPermissions" tmp_dir template True 0o666--openTempFile' :: String -> FilePath -> String -> Bool -> CMode-              -> IO (FilePath, Handle)-openTempFile' loc tmp_dir template binary mode-    | pathSeparator template-    = failIO $ "openTempFile': Template string must not contain path separator characters: "++template-    | otherwise = findTempName-  where-    -- We split off the last extension, so we can use .foo.ext files-    -- for temporary files (hidden on Unix OSes). Unfortunately we're-    -- below filepath in the hierarchy here.-    (prefix, suffix) =-       case break (== '.') $ reverse template of-         -- First case: template contains no '.'s. Just re-reverse it.-         (rev_suffix, "")       -> (reverse rev_suffix, "")-         -- Second case: template contains at least one '.'. Strip the-         -- dot from the prefix and prepend it to the suffix (if we don't-         -- do this, the unique number will get added after the '.' and-         -- thus be part of the extension, which is wrong.)-         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)-         -- 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.-         _                      -> errorWithoutStackTrace "bug in System.IO.openTempFile"-#if defined(mingw32_HOST_OS)-    findTempName = findTempNamePosix <!> findTempNameWinIO--    findTempNameWinIO = do-      let label = if null prefix then "ghc" else prefix-      withCWString tmp_dir $ \c_tmp_dir ->-        withCWString label $ \c_template ->-          withCWString suffix $ \c_suffix ->-            with nullPtr $ \c_ptr -> do-              res <- c_createUUIDTempFileErrNo c_tmp_dir c_template c_suffix c_ptr-              if not res-                 then do errno <- getErrno-                         ioError (errnoToIOError loc errno Nothing (Just tmp_dir))-                 else do c_p <- peek c_ptr-                         filename <- peekCWString c_p-                         free c_p-                         let flags = fromIntegral mode .&. o_EXCL-                         handleResultsWinIO filename (flags == o_EXCL)--    findTempNamePosix = do-      let label = if null prefix then "ghc" else prefix-      withCWString tmp_dir $ \c_tmp_dir ->-        withCWString label $ \c_template ->-          withCWString suffix $ \c_suffix ->-            allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do-            res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0-                                            c_str-            if not res-               then do errno <- getErrno-                       ioError (errnoToIOError loc errno Nothing (Just tmp_dir))-               else do filename <- peekCWString c_str-                       handleResultsPosix filename--    handleResultsPosix filename = do-      let oflags1 = rw_flags .|. o_EXCL-          binary_flags-              | binary    = o_BINARY-              | otherwise = 0-          oflags = oflags1 .|. binary_flags-      fd <- withFilePath filename $ \ f -> c_open f oflags mode-      case fd < 0 of-        True -> do errno <- getErrno-                   ioError (errnoToIOError loc errno Nothing (Just tmp_dir))-        False ->-          do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}-                                     False{-is_socket-}-                                     True{-is_nonblock-}--             enc <- getLocaleEncoding-             h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode-                                 False{-set non-block-} (Just enc)--             return (filename, h)--    handleResultsWinIO filename excl = do-      (hwnd, hwnd_type) <- openFileAsTemp filename True excl-      mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding--      -- then use it to make a Handle-      h <- mkHandleFromHANDLE hwnd hwnd_type filename ReadWriteMode mb_codec-                `onException` IODevice.close hwnd-      return (filename, h)--foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo-  :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool--foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo-  :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool--pathSeparator :: String -> Bool-pathSeparator template = any (\x-> x == '/' || x == '\\') template--output_flags = std_flags-#else /* else mingw32_HOST_OS */-    findTempName = do-      rs <- rand_string-      let filename = prefix ++ rs ++ suffix-          filepath = tmp_dir `combine` filename-      r <- openNewFile filepath binary mode-      case r of-        FileExists -> findTempName-        OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir))-        NewFileCreated fd -> do-          (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}-                               False{-is_socket-}-                               True{-is_nonblock-}--          enc <- getLocaleEncoding-          h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc)--          return (filepath, h)--      where-        -- XXX bits copied from System.FilePath, since that's not available here-        combine a b-                  | null b = a-                  | null a = b-                  | pathSeparator [last a] = a ++ b-                  | otherwise = a ++ [pathSeparatorChar] ++ b--tempCounter :: IORef Int-tempCounter = unsafePerformIO $ newIORef 0-{-# NOINLINE tempCounter #-}---- build large digit-alike number-rand_string :: IO String-rand_string = do-  r1 <- c_getpid-  (r2, _) <- atomicModifyIORef'_ tempCounter (+1)-  return $ show r1 ++ "-" ++ show r2--data OpenNewFileResult-  = NewFileCreated CInt-  | FileExists-  | OpenNewError Errno--openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult-openNewFile filepath binary mode = do-  let oflags1 = rw_flags .|. o_EXCL--      binary_flags-        | binary    = o_BINARY-        | otherwise = 0--      oflags = oflags1 .|. binary_flags-  fd <- withFilePath filepath $ \ f ->-          c_open f oflags mode-  if fd < 0-    then do-      errno <- getErrno-      case errno of-        _ | errno == eEXIST -> return FileExists-        _ -> return (OpenNewError errno)-    else return (NewFileCreated fd)---- XXX Should use filepath library-pathSeparatorChar :: Char-pathSeparatorChar = '/'--pathSeparator :: String -> Bool-pathSeparator template = pathSeparatorChar `elem` template--output_flags = std_flags    .|. o_CREAT-#endif /* mingw32_HOST_OS */---- XXX Copied from GHC.Handle-std_flags, output_flags, rw_flags :: CInt-std_flags    = o_NONBLOCK   .|. o_NOCTTY-rw_flags     = output_flags .|. o_RDWR---- $locking--- Implementations should enforce as far as possible, at least locally to the--- Haskell process, multiple-reader single-writer locking on files.--- That is, /there may either be many handles on the same file which manage input, or just one handle on the file which manages output/.  If any--- open or semi-closed handle is managing a file for output, no new--- handle can be allocated for that file.  If any open or semi-closed--- handle is managing a file for input, new handles can only be allocated--- if they do not manage output.  Whether two files are the same is--- implementation-dependent, but they should normally be the same if they--- have the same absolute path name and neither has been renamed, for--- example.------ /Warning/: the 'readFile' operation holds a semi-closed handle on--- the file until the entire contents of the file have been consumed.--- It follows that an attempt to write to a file (using 'writeFile', for--- example) that was earlier opened by 'readFile' will usually result in--- failure with 'System.IO.Error.isAlreadyInUseError'.
− System/IO/Error.hs 
@@ -1,363 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  System.IO.Error--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Standard IO Errors.-----------------------------------------------------------------------------------module System.IO.Error (--    -- * I\/O errors-    IOError,--    userError,--    mkIOError,--    annotateIOError,--    -- ** Classifying I\/O errors-    isAlreadyExistsError,-    isDoesNotExistError,-    isAlreadyInUseError,-    isFullError,-    isEOFError,-    isIllegalOperation,-    isPermissionError,-    isUserError,-    isResourceVanishedError,--    -- ** Attributes of I\/O errors-    ioeGetErrorType,-    ioeGetLocation,-    ioeGetErrorString,-    ioeGetHandle,-    ioeGetFileName,--    ioeSetErrorType,-    ioeSetErrorString,-    ioeSetLocation,-    ioeSetHandle,-    ioeSetFileName,--    -- * Types of I\/O error-    IOErrorType,                -- abstract--    alreadyExistsErrorType,-    doesNotExistErrorType,-    alreadyInUseErrorType,-    fullErrorType,-    eofErrorType,-    illegalOperationErrorType,-    permissionErrorType,-    userErrorType,-    resourceVanishedErrorType,--    -- ** 'IOErrorType' predicates-    isAlreadyExistsErrorType,-    isDoesNotExistErrorType,-    isAlreadyInUseErrorType,-    isFullErrorType,-    isEOFErrorType,-    isIllegalOperationErrorType,-    isPermissionErrorType,-    isUserErrorType,-    isResourceVanishedErrorType,--    -- * Throwing and catching I\/O errors--    ioError,--    catchIOError,-    tryIOError,--    modifyIOError,-  ) where--import Control.Exception.Base--import Data.Either-import Data.Maybe--import GHC.Base-import GHC.IO-import GHC.IO.Exception-import GHC.IO.Handle.Types-import Text.Show---- | The construct 'tryIOError' @comp@ exposes IO errors which occur within a--- computation, and which are not fully handled.------ Non-I\/O exceptions are not caught by this variant; to catch all--- exceptions, use 'Control.Exception.try' from "Control.Exception".------ @since 4.4.0.0-tryIOError     :: IO a -> IO (Either IOError a)-tryIOError f   =  catch (do r <- f-                            return (Right r))-                        (return . Left)---- -------------------------------------------------------------------------------- Constructing an IOError---- | Construct an 'IOError' of the given type where the second argument--- describes the error location and the third and fourth argument--- contain the file handle and file path of the file involved in the--- error if applicable.-mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> IOError-mkIOError t location maybe_hdl maybe_filename =-               IOError{ ioe_type = t,-                        ioe_location = location,-                        ioe_description = "",-                        ioe_errno = Nothing,-                        ioe_handle = maybe_hdl,-                        ioe_filename = maybe_filename-                        }---- -------------------------------------------------------------------------------- IOErrorType---- | An error indicating that an 'IO' operation failed because--- one of its arguments already exists.-isAlreadyExistsError :: IOError -> Bool-isAlreadyExistsError = isAlreadyExistsErrorType    . ioeGetErrorType---- | An error indicating that an 'IO' operation failed because--- one of its arguments does not exist.-isDoesNotExistError :: IOError -> Bool-isDoesNotExistError  = isDoesNotExistErrorType     . ioeGetErrorType---- | An error indicating that an 'IO' operation failed because--- one of its arguments is a single-use resource, which is already--- being used (for example, opening the same file twice for writing--- might give this error).-isAlreadyInUseError :: IOError -> Bool-isAlreadyInUseError  = isAlreadyInUseErrorType     . ioeGetErrorType---- | An error indicating that an 'IO' operation failed because--- the device is full.-isFullError         :: IOError -> Bool-isFullError          = isFullErrorType             . ioeGetErrorType---- | An error indicating that an 'IO' operation failed because--- the end of file has been reached.-isEOFError          :: IOError -> Bool-isEOFError           = isEOFErrorType              . ioeGetErrorType---- | An error indicating that an 'IO' operation failed because--- the operation was not possible.--- Any computation which returns an 'IO' result may fail with--- 'isIllegalOperation'.  In some cases, an implementation will not be--- able to distinguish between the possible error causes.  In this case--- it should fail with 'isIllegalOperation'.-isIllegalOperation  :: IOError -> Bool-isIllegalOperation   = isIllegalOperationErrorType . ioeGetErrorType---- | An error indicating that an 'IO' operation failed because--- the user does not have sufficient operating system privilege--- to perform that operation.-isPermissionError   :: IOError -> Bool-isPermissionError    = isPermissionErrorType       . ioeGetErrorType---- | A programmer-defined error value constructed using 'userError'.-isUserError         :: IOError -> Bool-isUserError          = isUserErrorType             . ioeGetErrorType---- | An error indicating that the operation failed because the--- resource vanished. See 'resourceVanishedErrorType'.------ @since 4.14.0.0-isResourceVanishedError :: IOError -> Bool-isResourceVanishedError = isResourceVanishedErrorType . ioeGetErrorType---- -------------------------------------------------------------------------------- IOErrorTypes---- | I\/O error where the operation failed because one of its arguments--- already exists.-alreadyExistsErrorType   :: IOErrorType-alreadyExistsErrorType    = AlreadyExists---- | I\/O error where the operation failed because one of its arguments--- does not exist.-doesNotExistErrorType    :: IOErrorType-doesNotExistErrorType     = NoSuchThing---- | I\/O error where the operation failed because one of its arguments--- is a single-use resource, which is already being used.-alreadyInUseErrorType    :: IOErrorType-alreadyInUseErrorType     = ResourceBusy---- | I\/O error where the operation failed because the device is full.-fullErrorType            :: IOErrorType-fullErrorType             = ResourceExhausted---- | I\/O error where the operation failed because the end of file has--- been reached.-eofErrorType             :: IOErrorType-eofErrorType              = EOF---- | I\/O error where the operation is not possible.-illegalOperationErrorType :: IOErrorType-illegalOperationErrorType = IllegalOperation---- | I\/O error where the operation failed because the user does not--- have sufficient operating system privilege to perform that operation.-permissionErrorType      :: IOErrorType-permissionErrorType       = PermissionDenied---- | I\/O error that is programmer-defined.-userErrorType            :: IOErrorType-userErrorType             = UserError---- | I\/O error where the operation failed because the resource vanished.--- This happens when, for example, attempting to write to a closed--- socket or attempting to write to a named pipe that was deleted.------ @since 4.14.0.0-resourceVanishedErrorType :: IOErrorType-resourceVanishedErrorType = ResourceVanished---- -------------------------------------------------------------------------------- IOErrorType predicates---- | I\/O error where the operation failed because one of its arguments--- already exists.-isAlreadyExistsErrorType :: IOErrorType -> Bool-isAlreadyExistsErrorType AlreadyExists = True-isAlreadyExistsErrorType _ = False---- | I\/O error where the operation failed because one of its arguments--- does not exist.-isDoesNotExistErrorType :: IOErrorType -> Bool-isDoesNotExistErrorType NoSuchThing = True-isDoesNotExistErrorType _ = False---- | I\/O error where the operation failed because one of its arguments--- is a single-use resource, which is already being used.-isAlreadyInUseErrorType :: IOErrorType -> Bool-isAlreadyInUseErrorType ResourceBusy = True-isAlreadyInUseErrorType _ = False---- | I\/O error where the operation failed because the device is full.-isFullErrorType :: IOErrorType -> Bool-isFullErrorType ResourceExhausted = True-isFullErrorType _ = False---- | I\/O error where the operation failed because the end of file has--- been reached.-isEOFErrorType :: IOErrorType -> Bool-isEOFErrorType EOF = True-isEOFErrorType _ = False---- | I\/O error where the operation is not possible.-isIllegalOperationErrorType :: IOErrorType -> Bool-isIllegalOperationErrorType IllegalOperation = True-isIllegalOperationErrorType _ = False---- | I\/O error where the operation failed because the user does not--- have sufficient operating system privilege to perform that operation.-isPermissionErrorType :: IOErrorType -> Bool-isPermissionErrorType PermissionDenied = True-isPermissionErrorType _ = False---- | I\/O error that is programmer-defined.-isUserErrorType :: IOErrorType -> Bool-isUserErrorType UserError = True-isUserErrorType _ = False---- | I\/O error where the operation failed because the resource vanished.--- See 'resourceVanishedErrorType'.------ @since 4.14.0.0-isResourceVanishedErrorType :: IOErrorType -> Bool-isResourceVanishedErrorType ResourceVanished = True-isResourceVanishedErrorType _ = False---- -------------------------------------------------------------------------------- Miscellaneous--ioeGetErrorType       :: IOError -> IOErrorType-ioeGetErrorString     :: IOError -> String-ioeGetLocation        :: IOError -> String-ioeGetHandle          :: IOError -> Maybe Handle-ioeGetFileName        :: IOError -> Maybe FilePath--ioeGetErrorType ioe = ioe_type ioe--ioeGetErrorString ioe-   | isUserErrorType (ioe_type ioe) = ioe_description ioe-   | otherwise                      = show (ioe_type ioe)--ioeGetLocation ioe = ioe_location ioe--ioeGetHandle ioe = ioe_handle ioe--ioeGetFileName ioe = ioe_filename ioe--ioeSetErrorType   :: IOError -> IOErrorType -> IOError-ioeSetErrorString :: IOError -> String      -> IOError-ioeSetLocation    :: IOError -> String      -> IOError-ioeSetHandle      :: IOError -> Handle      -> IOError-ioeSetFileName    :: IOError -> FilePath    -> IOError--ioeSetErrorType   ioe errtype  = ioe{ ioe_type = errtype }-ioeSetErrorString ioe str      = ioe{ ioe_description = str }-ioeSetLocation    ioe str      = ioe{ ioe_location = str }-ioeSetHandle      ioe hdl      = ioe{ ioe_handle = Just hdl }-ioeSetFileName    ioe filename = ioe{ ioe_filename = Just filename }---- | Catch any 'IOError' that occurs in the computation and throw a--- modified version.-modifyIOError :: (IOError -> IOError) -> IO a -> IO a-modifyIOError f io = catch io (\e -> ioError (f e))---- -------------------------------------------------------------------------------- annotating an IOError---- | Adds a location description and maybe a file path and file handle--- to an 'IOError'.  If any of the file handle or file path is not given--- the corresponding value in the 'IOError' remains unaltered.-annotateIOError :: IOError-              -> String-              -> Maybe Handle-              -> Maybe FilePath-              -> IOError-annotateIOError ioe loc hdl path =-  ioe{ ioe_handle = hdl `mplus` ioe_handle ioe,-       ioe_location = loc, ioe_filename = path `mplus` ioe_filename ioe }---- | The 'catchIOError' function establishes a handler that receives any--- 'IOError' raised in the action protected by 'catchIOError'.--- An 'IOError' is caught by--- the most recent handler established by one of the exception handling--- functions.  These handlers are--- not selective: all 'IOError's are caught.  Exception propagation--- must be explicitly provided in a handler by re-raising any unwanted--- exceptions.  For example, in------ > f = catchIOError g (\e -> if IO.isEOFError e then return [] else ioError e)------ the function @f@ returns @[]@ when an end-of-file exception--- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the--- exception is propagated to the next outer handler.------ When an exception propagates outside the main program, the Haskell--- system prints the associated 'IOError' value and exits the program.------ Non-I\/O exceptions are not caught by this variant; to catch all--- exceptions, use 'Control.Exception.catch' from "Control.Exception".------ @since 4.4.0.0-catchIOError :: IO a -> (IOError -> IO a) -> IO a-catchIOError = catch
− System/IO/Unsafe.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  System.IO.Unsafe--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ \"Unsafe\" IO operations.-----------------------------------------------------------------------------------module System.IO.Unsafe (-   -- * Unsafe 'System.IO.IO' operations-   unsafePerformIO,-   unsafeDupablePerformIO,-   unsafeInterleaveIO,-   unsafeFixIO,-  ) where--import GHC.Base-import GHC.IO-import GHC.IORef-import GHC.Exception-import Control.Exception---- | A slightly faster version of `System.IO.fixIO` that may not be--- safe to use with multiple threads.  The unsafety arises when used--- like this:------ >  unsafeFixIO $ \r -> do--- >     forkIO (print r)--- >     return (...)------ In this case, the child thread will receive a @NonTermination@--- exception instead of waiting for the value of @r@ to be computed.------ @since 4.5.0.0-unsafeFixIO :: (a -> IO a) -> IO a-unsafeFixIO k = do-  ref <- newIORef (throw NonTermination)-  ans <- unsafeDupableInterleaveIO (readIORef ref)-  result <- k ans-  writeIORef ref result-  return result
− System/Info.hs 
@@ -1,110 +0,0 @@-{-# LANGUAGE CPP  #-}-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  System.Info--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  portable------ Information about the characteristics of the host--- system lucky enough to run your program.------ For a comprehensive listing of supported platforms, please refer to--- https://gitlab.haskell.org/ghc/ghc/-/wikis/platforms--------------------------------------------------------------------------------module System.Info-  ( os-  , arch-  , compilerName-  , compilerVersion-  , fullCompilerVersion-  ) where--import           Data.Version (Version (..))---- | The version of 'compilerName' with which the program was compiled--- or is being interpreted.------ ==== __Example__--- > ghci> compilerVersion--- > Version {versionBranch = [8,8], versionTags = []}-compilerVersion :: Version-compilerVersion = Version [major, minor] []-  where (major, minor) = compilerVersionRaw `divMod` 100---- | The full version of 'compilerName' with which the program was compiled--- or is being interpreted. It includes the major, minor, revision and an additional--- identifier, generally in the form "<year><month><day>".-fullCompilerVersion :: Version-fullCompilerVersion = Version version []-  where-    version :: [Int]-    version = fmap read $ splitVersion __GLASGOW_HASKELL_FULL_VERSION__--splitVersion :: String -> [String]-splitVersion s =-  case dropWhile (== '.') s of-    "" -> []-    s' -> let (w, s'') = break (== '.') s'-           in w : splitVersion s''--#include "ghcplatform.h"---- | The operating system on which the program is running.--- Common values include:------     * "darwin" — macOS---     * "freebsd"---     * "linux"---     * "linux-android"---     * "mingw32" — Windows---     * "netbsd"---     * "openbsd"-os :: String-os = HOST_OS---- | The machine architecture on which the program is running.--- Common values include:------    * "aarch64"---    * "alpha"---    * "arm"---    * "hppa"---    * "hppa1_1"---    * "i386"---    * "ia64"---    * "m68k"---    * "mips"---    * "mipseb"---    * "mipsel"---    * "nios2"---    * "powerpc"---    * "powerpc64"---    * "powerpc64le"---    * "riscv32"---    * "riscv64"---    * "rs6000"---    * "s390"---    * "s390x"---    * "sh4"---    * "sparc"---    * "sparc64"---    * "vax"---    * "x86_64"-arch :: String-arch = HOST_ARCH---- | The Haskell implementation with which the program was compiled--- or is being interpreted.--- On the GHC platform, the value is "ghc".-compilerName :: String-compilerName = "ghc"--compilerVersionRaw :: Int-compilerVersionRaw = __GLASGOW_HASKELL__
− System/Mem.hs 
@@ -1,46 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  System.Mem--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Memory-related system things.-----------------------------------------------------------------------------------{-# LANGUAGE Trustworthy #-}--- allocation counter stuff is safe, but GHC.Conc.Sync is Unsafe--module System.Mem-       (-       -- * Garbage collection-         performGC-       , performMajorGC-       , performMinorGC--        -- * Allocation counter and limits-        , setAllocationCounter-        , getAllocationCounter-        , enableAllocationLimit-        , disableAllocationLimit-       ) where--import GHC.Conc.Sync---- | Triggers an immediate major garbage collection.-performGC :: IO ()-performGC = performMajorGC---- | Triggers an immediate major garbage collection.------ @since 4.7.0.0-foreign import ccall "performMajorGC" performMajorGC :: IO ()---- | Triggers an immediate minor garbage collection.------ @since 4.7.0.0-foreign import ccall "performGC" performMinorGC :: IO ()
− System/Mem/StableName.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE Safe #-}---------------------------------------------------------------------------------- |--- Module      :  System.Mem.StableName--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Stable names are a way of performing fast ( \(\mathcal{O}(1)\) ),--- not-quite-exact comparison between objects.------ Stable names solve the following problem: suppose you want to build--- a hash table with Haskell objects as keys, but you want to use--- pointer equality for comparison; maybe because the keys are large--- and hashing would be slow, or perhaps because the keys are infinite--- in size.  We can\'t build a hash table using the address of the--- object as the key, because objects get moved around by the garbage--- collector, meaning a re-hash would be necessary after every garbage--- collection.-------------------------------------------------------------------------------------module System.Mem.StableName (-  -- * Stable Names-  StableName,-  makeStableName,-  hashStableName,-  eqStableName-  ) where--import GHC.StableName
− System/Mem/Weak.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  System.Mem.Weak--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ In general terms, a weak pointer is a reference to an object that is--- not followed by the garbage collector - that is, the existence of a--- weak pointer to an object has no effect on the lifetime of that--- object.  A weak pointer can be de-referenced to find out--- whether the object it refers to is still alive or not, and if so--- to return the object itself.------ Weak pointers are particularly useful for caches and memo tables.--- To build a memo table, you build a data structure--- mapping from the function argument (the key) to its result (the--- value).  When you apply the function to a new argument you first--- check whether the key\/value pair is already in the memo table.--- The key point is that the memo table itself should not keep the--- key and value alive.  So the table should contain a weak pointer--- to the key, not an ordinary pointer.  The pointer to the value must--- not be weak, because the only reference to the value might indeed be--- from the memo table.------ So it looks as if the memo table will keep all its values--- alive for ever.  One way to solve this is to purge the table--- occasionally, by deleting entries whose keys have died.------ The weak pointers in this library--- support another approach, called /finalization/.--- When the key referred to by a weak pointer dies, the storage manager--- arranges to run a programmer-specified finalizer.  In the case of memo--- tables, for example, the finalizer could remove the key\/value pair--- from the memo table.------ Another difficulty with the memo table is that the value of a--- key\/value pair might itself contain a pointer to the key.--- So the memo table keeps the value alive, which keeps the key alive,--- even though there may be no other references to the key so both should--- die.  The weak pointers in this library provide a slight--- generalisation of the basic weak-pointer idea, in which each--- weak pointer actually contains both a key and a value.-----------------------------------------------------------------------------------module System.Mem.Weak (-        -- * The @Weak@ type-        Weak,                   -- abstract--        -- * The general interface-        mkWeak,-        deRefWeak,-        finalize,--        -- * Specialised versions-        mkWeakPtr,-        addFinalizer,-        mkWeakPair,-        -- replaceFinaliser--        -- * A precise semantics--        -- $precise--        -- * Implementation notes--        -- $notes-   ) where--import GHC.Weak---- | A specialised version of 'mkWeak', where the key and the value are--- the same object:------ > mkWeakPtr key finalizer = mkWeak key key finalizer----mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k)-mkWeakPtr key finalizer = mkWeak key key finalizer--{-|-  A specialised version of 'mkWeakPtr', where the 'Weak' object-  returned is simply thrown away (however the finalizer will be-  remembered by the garbage collector, and will still be run-  when the key becomes unreachable).--  Note: adding a finalizer to a 'Foreign.ForeignPtr.ForeignPtr' using-  'addFinalizer' won't work; use the specialised version-  'Foreign.ForeignPtr.addForeignPtrFinalizer' instead.  For discussion-  see the 'Weak' type.-.--}-addFinalizer :: key -> IO () -> IO ()-addFinalizer key finalizer = do-   _ <- mkWeakPtr key (Just finalizer) -- throw it away-   return ()---- | A specialised version of 'mkWeak' where the value is actually a pair--- of the key and value passed to 'mkWeakPair':------ > mkWeakPair key val finalizer = mkWeak key (key,val) finalizer------ The advantage of this is that the key can be retrieved by 'deRefWeak'--- in addition to the value.-mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))-mkWeakPair key val finalizer = mkWeak key (key,val) finalizer---{- $precise--The above informal specification is fine for simple situations, but-matters can get complicated.  In particular, it needs to be clear-exactly when a key dies, so that any weak pointers that refer to it-can be finalized.  Suppose, for example, the value of one weak pointer-refers to the key of another...does that keep the key alive?--The behaviour is simply this:-- *  If a weak pointer (object) refers to an /unreachable/-    key, it may be finalized.-- *  Finalization means (a) arrange that subsequent calls-    to 'deRefWeak' return 'Nothing'; and (b) run the finalizer.--This behaviour depends on what it means for a key to be reachable.-Informally, something is reachable if it can be reached by following-ordinary pointers from the root set, but not following weak pointers.-We define reachability more precisely as follows.--A heap object is /reachable/ if:-- * It is a member of the /root set/.-- * It is directly pointed to by a reachable object, other than-   a weak pointer object.-- * It is a weak pointer object whose key is reachable.-- * It is the value or finalizer of a weak pointer object whose key is reachable.--}--{- $notes--A finalizer is not always called after its weak pointer\'s object becomes-unreachable. If the object becomes unreachable right before the program exits,-then GC may not be performed. Finalizers run during GC, so finalizers associated-with the object do not run if GC does not happen.--Other than the above caveat, users can always expect that a finalizer will be-run after its weak pointer\'s object becomes unreachable.--If a finalizer throws an exception, the exception is silently caught without-notice. See the commit of issue-<https://gitlab.haskell.org/ghc/ghc/-/issues/13167 13167> for details. Writing a-finalizer that throws exceptions is discouraged.---}
− System/Posix/Internals.hs 
@@ -1,668 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE MagicHash #-}-{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  System.Posix.Internals--- Copyright   :  (c) The University of Glasgow, 1992-2002--- License     :  see libraries/base/LICENSE------ Maintainer  :  cvs-ghc@haskell.org--- Stability   :  internal--- Portability :  non-portable (requires POSIX)------ POSIX support layer for the standard libraries.--- This library is built on *every* platform, including Win32.------ Non-posix compliant in order to support the following features:---      * S_ISSOCK (no sockets in POSIX)-----------------------------------------------------------------------------------module System.Posix.Internals where--#include "HsBaseConfig.h"--import System.Posix.Types--import Foreign-import Foreign.C---- import Data.Bits-import Data.Maybe--#if !defined(HTYPE_TCFLAG_T)-import System.IO.Error-#endif--import GHC.Base-import GHC.Num-import GHC.Real-import GHC.IO-import GHC.IO.IOMode-import GHC.IO.Exception-import GHC.IO.Device-#if !defined(mingw32_HOST_OS)-import {-# SOURCE #-} GHC.IO.Encoding (getFileSystemEncoding)-import qualified GHC.Foreign as GHC-#endif---- ------------------------------------------------------------------------------ Debugging the base package--puts :: String -> IO ()-puts s = withCAStringLen (s ++ "\n") $ \(p, len) -> do-            -- In reality should be withCString, but assume ASCII to avoid loop-            -- if this is called by GHC.Foreign-           _ <- c_write 1 (castPtr p) (fromIntegral len)-           return ()----- ------------------------------------------------------------------------------ Types--data {-# CTYPE "struct flock" #-} CFLock-data {-# CTYPE "struct group" #-} CGroup-data {-# CTYPE "struct lconv" #-} CLconv-data {-# CTYPE "struct passwd" #-} CPasswd-data {-# CTYPE "struct sigaction" #-} CSigaction-data {-# CTYPE "sigset_t" #-} CSigset-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---- ------------------------------------------------------------------------------ stat()-related stuff--fdFileSize :: FD -> IO Integer-fdFileSize fd =-  allocaBytes sizeof_stat $ \ p_stat -> do-    throwErrnoIfMinus1Retry_ "fileSize" $-        c_fstat fd p_stat-    c_mode <- st_mode p_stat :: IO CMode-    if not (s_isreg c_mode)-        then return (-1)-        else do-      c_size <- st_size p_stat-      return (fromIntegral c_size)--fileType :: FilePath -> IO IODeviceType-fileType file =-  allocaBytes sizeof_stat $ \ p_stat ->-  withFilePath file $ \p_file -> do-    throwErrnoIfMinus1Retry_ "fileType" $-      c_stat p_file p_stat-    statGetType p_stat---- NOTE: On Win32 platforms, this will only work with file descriptors--- referring to file handles. i.e., it'll fail for socket FDs.-fdStat :: FD -> IO (IODeviceType, CDev, CIno)-fdStat fd =-  allocaBytes sizeof_stat $ \ p_stat -> do-    throwErrnoIfMinus1Retry_ "fdType" $-        c_fstat fd p_stat-    ty <- statGetType p_stat-    dev <- st_dev p_stat-    ino <- st_ino p_stat-    return (ty,dev,ino)--fdType :: FD -> IO IODeviceType-fdType fd = do (ty,_,_) <- fdStat fd; return ty--statGetType :: Ptr CStat -> IO IODeviceType-statGetType p_stat = do-  c_mode <- st_mode p_stat :: IO CMode-  case () of-      _ | s_isdir c_mode        -> return Directory-        | s_isfifo c_mode || s_issock c_mode || s_ischr  c_mode-                                -> return Stream-        | s_isreg c_mode        -> return RegularFile-         -- Q: map char devices to RawDevice too?-        | s_isblk c_mode        -> return RawDevice-        | otherwise             -> ioError ioe_unknownfiletype--ioe_unknownfiletype :: IOException-ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"-                        "unknown file type"-                        Nothing-                        Nothing--fdGetMode :: FD -> IO IOMode-#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.-    let flags = o_RDWR-#else-fdGetMode fd = do-    flags <- throwErrnoIfMinus1Retry "fdGetMode"-                (c_fcntl_read fd const_f_getfl)-#endif-    let-       wH  = (flags .&. o_WRONLY) /= 0-       aH  = (flags .&. o_APPEND) /= 0-       rwH = (flags .&. o_RDWR) /= 0--       mode-         | wH && aH  = AppendMode-         | wH        = WriteMode-         | rwH       = ReadWriteMode-         | otherwise = ReadMode--    return mode--#if defined(mingw32_HOST_OS)-withFilePath :: FilePath -> (CWString -> IO a) -> IO a-withFilePath = withCWString--newFilePath :: FilePath -> IO CWString-newFilePath = newCWString--peekFilePath :: CWString -> IO FilePath-peekFilePath = peekCWString-#else--withFilePath :: FilePath -> (CString -> IO a) -> IO a-newFilePath :: FilePath -> IO CString-peekFilePath :: CString -> IO FilePath-peekFilePathLen :: CStringLen -> IO FilePath--withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f-newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp-peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp-peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp--#endif---- ------------------------------------------------------------------------------ Terminal-related stuff--#if defined(HTYPE_TCFLAG_T)--setEcho :: FD -> Bool -> IO ()-setEcho fd on =-  tcSetAttr fd $ \ p_tios -> do-    lflag <- c_lflag p_tios :: IO CTcflag-    let new_lflag-         | on        = lflag .|. fromIntegral const_echo-         | otherwise = lflag .&. complement (fromIntegral const_echo)-    poke_c_lflag p_tios (new_lflag :: CTcflag)--getEcho :: FD -> IO Bool-getEcho fd =-  tcSetAttr fd $ \ p_tios -> do-    lflag <- c_lflag p_tios :: IO CTcflag-    return ((lflag .&. fromIntegral const_echo) /= 0)--setCooked :: FD -> Bool -> IO ()-setCooked fd cooked =-  tcSetAttr fd $ \ p_tios -> do--    -- turn on/off ICANON-    lflag <- c_lflag p_tios :: IO CTcflag-    let new_lflag | cooked    = lflag .|. (fromIntegral const_icanon)-                  | otherwise = lflag .&. complement (fromIntegral const_icanon)-    poke_c_lflag p_tios (new_lflag :: CTcflag)--    -- set VMIN & VTIME to 1/0 respectively-    when (not cooked) $ do-            c_cc <- ptr_c_cc p_tios-            let vmin  = (c_cc `plusPtr` (fromIntegral const_vmin))  :: Ptr Word8-                vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8-            poke vmin  1-            poke vtime 0--tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a-tcSetAttr fd fun =-     allocaBytes sizeof_termios  $ \p_tios -> do-        throwErrnoIfMinus1Retry_ "tcSetAttr"-           (c_tcgetattr fd p_tios)--        -- Save a copy of termios, if this is a standard file descriptor.-        -- These terminal settings are restored in hs_exit().-        when (fd <= 2) $ do-          p <- get_saved_termios fd-          when (p == nullPtr) $ do-             saved_tios <- mallocBytes sizeof_termios-             copyBytes saved_tios p_tios sizeof_termios-             set_saved_termios fd saved_tios--        -- tcsetattr() when invoked by a background process causes the process-        -- to be sent SIGTTOU regardless of whether the process has TOSTOP set-        -- in its terminal flags (try it...).  This function provides a-        -- wrapper which temporarily blocks SIGTTOU around the call, making it-        -- transparent.-        allocaBytes sizeof_sigset_t $ \ p_sigset ->-          allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do-             throwErrnoIfMinus1_ "sigemptyset" $-                 c_sigemptyset p_sigset-             throwErrnoIfMinus1_ "sigaddset" $-                 c_sigaddset   p_sigset const_sigttou-             throwErrnoIfMinus1_ "sigprocmask" $-                 c_sigprocmask const_sig_block p_sigset p_old_sigset-             r <- fun p_tios  -- do the business-             throwErrnoIfMinus1Retry_ "tcSetAttr" $-                 c_tcsetattr fd const_tcsanow p_tios-             throwErrnoIfMinus1_ "sigprocmask" $-                 c_sigprocmask const_sig_setmask p_old_sigset nullPtr-             return r--foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"-   get_saved_termios :: CInt -> IO (Ptr CTermios)--foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"-   set_saved_termios :: CInt -> (Ptr CTermios) -> IO ()--#else---- 'raw' mode for Win32 means turn off 'line input' (=> buffering and--- character translation for the console.) The Win32 API for doing--- this is GetConsoleMode(), which also requires echoing to be disabled--- when turning off 'line input' processing. Notice that turning off--- 'line input' implies enter/return is reported as '\r' (and it won't--- report that character until another character is input..odd.) This--- latter feature doesn't sit too well with IO actions like IO.hGetLine..--- consider yourself warned.-setCooked :: FD -> Bool -> IO ()-setCooked fd cooked = do-  x <- set_console_buffering fd (if cooked then 1 else 0)-  if (x /= 0)-   then ioError (ioe_unk_error "setCooked" "failed to set buffering")-   else return ()--ioe_unk_error :: String -> String -> IOException-ioe_unk_error loc msg- = ioeSetErrorString (mkIOError OtherError loc Nothing Nothing) msg---- Note: echoing goes hand in hand with enabling 'line input' / raw-ness--- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.-setEcho :: FD -> Bool -> IO ()-setEcho fd on = do-  x <- set_console_echo fd (if on then 1 else 0)-  if (x /= 0)-   then ioError (ioe_unk_error "setEcho" "failed to set echoing")-   else return ()--getEcho :: FD -> IO Bool-getEcho fd = do-  r <- get_console_echo fd-  if (r == (-1))-   then ioError (ioe_unk_error "getEcho" "failed to get echoing")-   else return (r == 1)--foreign import ccall unsafe "consUtils.h set_console_buffering__"-   set_console_buffering :: CInt -> CInt -> IO CInt--foreign import ccall unsafe "consUtils.h set_console_echo__"-   set_console_echo :: CInt -> CInt -> IO CInt--foreign import ccall unsafe "consUtils.h get_console_echo__"-   get_console_echo :: CInt -> IO CInt--foreign import ccall unsafe "consUtils.h is_console__"-   is_console :: CInt -> IO CInt--#endif---- ------------------------------------------------------------------------------ Turning on non-blocking for a file descriptor--setNonBlockingFD :: FD -> Bool -> IO ()-#if !defined(mingw32_HOST_OS)-setNonBlockingFD fd set = do-  flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"-                 (c_fcntl_read fd const_f_getfl)-  let flags' | set       = flags .|. o_NONBLOCK-             | otherwise = flags .&. complement o_NONBLOCK-  when (flags /= flags') $ do-    -- An error when setting O_NONBLOCK isn't fatal: on some systems-    -- there are certain file handles on which this will fail (eg. /dev/null-    -- on FreeBSD) so we throw away the return code from fcntl_write.-    _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags')-    return ()-#else---- bogus defns for win32-setNonBlockingFD _ _ = return ()--#endif---- -------------------------------------------------------------------------------- Set close-on-exec for a file descriptor--#if !defined(mingw32_HOST_OS)-setCloseOnExec :: FD -> IO ()-setCloseOnExec fd =-  throwErrnoIfMinus1_ "setCloseOnExec" $-    c_fcntl_write fd const_f_setfd const_fd_cloexec-#endif---- -------------------------------------------------------------------------------- foreign imports--#if !defined(mingw32_HOST_OS)-type CFilePath = CString-#else-type CFilePath = CWString-#endif--foreign import ccall unsafe "HsBase.h __hscore_open"-   c_open :: CFilePath -> CInt -> CMode -> IO CInt---- | The same as 'c_safe_open', but an /interruptible operation/--- as described in "Control.Exception"—it respects `uninterruptibleMask`--- but not `mask`.------ We want to be able to interrupt an openFile call if--- it's expensive (NFS, FUSE, etc.), and we especially--- need to be able to interrupt a blocking open call.--- See #17912.-c_interruptible_open :: CFilePath -> CInt -> CMode -> IO CInt-c_interruptible_open filepath oflags mode =-  getMaskingState >>= \case-    -- If we're in an uninterruptible mask, there's basically-    -- no point in using an interruptible FFI call. The open system call-    -- will be interrupted, but the exception won't be delivered-    -- unless the caller manually futzes with the masking state. So-    -- then the caller (assuming they're following the usual conventions)-    -- will retry the call (in response to EINTR), and we've just-    -- wasted everyone's time.-    MaskedUninterruptible -> c_safe_open_ filepath oflags mode-    _ -> do-      open_res <- c_interruptible_open_ filepath oflags mode-      -- c_interruptible_open_ is an interruptible foreign call.-      -- If the call is interrupted by an exception handler-      -- before the system call has returned (so the file is-      -- not yet open), we want to deliver the exception.-      -- In point of fact, we deliver any pending exception-      -- here regardless of the *reason* the system call-      -- fails.-      when (open_res == -1) $-        if hostIsThreaded-          then-            -- Control.Exception.allowInterrupt, inlined to avoid-            -- messing with any Haddock links.-            interruptible (pure ())-          else-            -- Try to make this work somewhat better on the non-threaded-            -- RTS. See #8684. This inlines the definition of `yield`; module-            -- dependencies look pretty hairy here and I don't want to make-            -- things worse for one little wrapper.-            interruptible (IO $ \s -> (# yield# s, () #))-      pure open_res--foreign import ccall interruptible "HsBase.h __hscore_open"-   c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt---- | Consult the RTS to find whether it is threaded.-hostIsThreaded :: Bool-hostIsThreaded = rtsIsThreaded_ /= 0--foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int--c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt-c_safe_open filepath oflags mode =-  getMaskingState >>= \case-    -- When exceptions are unmasked, we use an interruptible-    -- open call. If the system call is successfully-    -- interrupted, the situation will be the same as if-    -- the exception had arrived before this function was-    -- called.-    Unmasked -> c_interruptible_open_ filepath oflags mode-    _ -> c_safe_open_ filepath oflags mode--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.--However since we can't hope to get people to support Windows-packages we should support the deprecated names. See #12497--}-foreign import capi unsafe "unistd.h lseek"-   c_lseek :: CInt -> COff -> CInt -> IO COff--foreign import ccall unsafe "HsBase.h access"-   c_access :: CString -> CInt -> IO CInt--foreign import ccall unsafe "HsBase.h chmod"-   c_chmod :: CString -> 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--#if defined(mingw32_HOST_OS)--- See Note: Windows types-foreign import capi unsafe "HsBase.h _read"-   c_read :: CInt -> Ptr Word8 -> CUInt -> IO CInt---- See Note: Windows types-foreign import capi safe "HsBase.h _read"-   c_safe_read :: CInt -> Ptr Word8 -> CUInt -> IO CInt--foreign import ccall unsafe "HsBase.h _umask"-   c_umask :: CMode -> IO CMode---- See Note: Windows types-foreign import capi unsafe "HsBase.h _write"-   c_write :: CInt -> Ptr Word8 -> CUInt -> IO CInt---- See Note: Windows types-foreign import capi safe "HsBase.h _write"-   c_safe_write :: CInt -> Ptr Word8 -> CUInt -> IO CInt--foreign import ccall unsafe "HsBase.h _pipe"-   c_pipe :: Ptr CInt -> IO CInt-#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.---- See Note: Windows types-foreign import capi unsafe "HsBase.h read"-   c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize---- See Note: Windows types-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: Windows types-foreign import capi unsafe "HsBase.h write"-   c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize---- See Note: Windows types-foreign import capi safe "HsBase.h write"-   c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize--foreign import ccall unsafe "HsBase.h pipe"-   c_pipe :: Ptr CInt -> IO CInt-#endif--foreign import ccall unsafe "HsBase.h unlink"-   c_unlink :: CString -> 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--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--foreign import capi unsafe "HsBase.h fcntl"-   c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt--foreign import capi unsafe "HsBase.h fcntl"-   c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt--foreign import ccall unsafe "HsBase.h fork"-   c_fork :: IO CPid--foreign import ccall unsafe "HsBase.h link"-   c_link :: CString -> CString -> IO CInt---- capi is required at least on Android-foreign import capi unsafe "HsBase.h mkfifo"-   c_mkfifo :: CString -> CMode -> IO CInt--foreign import capi unsafe "signal.h sigemptyset"-   c_sigemptyset :: Ptr CSigset -> IO CInt--foreign import capi unsafe "signal.h sigaddset"-   c_sigaddset :: Ptr CSigset -> CInt -> IO CInt--foreign import capi unsafe "signal.h sigprocmask"-   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt---- capi is required at least on Android-foreign import capi unsafe "HsBase.h tcgetattr"-   c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt---- capi is required at least on Android-foreign import capi unsafe "HsBase.h tcsetattr"-   c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt--foreign import ccall unsafe "HsBase.h waitpid"-   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid-#endif---- POSIX flags only:-foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_rdwr"   o_RDWR   :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_creat"  o_CREAT  :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_excl"   o_EXCL   :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_trunc"  o_TRUNC  :: CInt---- non-POSIX flags.-foreign import ccall unsafe "HsBase.h __hscore_o_noctty"   o_NOCTTY   :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_nonblock" o_NONBLOCK :: CInt-foreign import ccall unsafe "HsBase.h __hscore_o_binary"   o_BINARY   :: CInt--foreign import capi unsafe "sys/stat.h S_ISREG"  c_s_isreg  :: CMode -> CInt-foreign import capi unsafe "sys/stat.h S_ISCHR"  c_s_ischr  :: CMode -> CInt-foreign import capi unsafe "sys/stat.h S_ISBLK"  c_s_isblk  :: CMode -> CInt-foreign import capi unsafe "sys/stat.h S_ISDIR"  c_s_isdir  :: CMode -> CInt-foreign import capi unsafe "sys/stat.h S_ISFIFO" c_s_isfifo :: CMode -> CInt--s_isreg  :: CMode -> Bool-s_isreg cm = c_s_isreg cm /= 0-s_ischr  :: CMode -> Bool-s_ischr cm = c_s_ischr cm /= 0-s_isblk  :: CMode -> Bool-s_isblk cm = c_s_isblk cm /= 0-s_isdir  :: CMode -> Bool-s_isdir cm = c_s_isdir cm /= 0-s_isfifo :: CMode -> Bool-s_isfifo cm = c_s_isfifo cm /= 0--foreign import ccall unsafe "HsBase.h __hscore_sizeof_stat" sizeof_stat :: Int-foreign import ccall unsafe "HsBase.h __hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime-#if defined(mingw32_HOST_OS)-foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO Int64-#else-foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO COff-#endif-foreign import ccall unsafe "HsBase.h __hscore_st_mode" st_mode :: Ptr CStat -> IO CMode-foreign import ccall unsafe "HsBase.h __hscore_st_dev" st_dev :: Ptr CStat -> IO CDev-foreign import ccall unsafe "HsBase.h __hscore_st_ino" st_ino :: Ptr CStat -> IO CIno--foreign import ccall unsafe "HsBase.h __hscore_echo"         const_echo :: CInt-foreign import ccall unsafe "HsBase.h __hscore_tcsanow"      const_tcsanow :: CInt-foreign import ccall unsafe "HsBase.h __hscore_icanon"       const_icanon :: CInt-foreign import ccall unsafe "HsBase.h __hscore_vmin"         const_vmin   :: CInt-foreign import ccall unsafe "HsBase.h __hscore_vtime"        const_vtime  :: CInt-foreign import ccall unsafe "HsBase.h __hscore_sigttou"      const_sigttou :: CInt-foreign import ccall unsafe "HsBase.h __hscore_sig_block"    const_sig_block :: CInt-foreign import ccall unsafe "HsBase.h __hscore_sig_setmask"  const_sig_setmask :: CInt-foreign import ccall unsafe "HsBase.h __hscore_f_getfl"      const_f_getfl :: CInt-foreign import ccall unsafe "HsBase.h __hscore_f_setfl"      const_f_setfl :: CInt-foreign import ccall unsafe "HsBase.h __hscore_f_setfd"      const_f_setfd :: CInt-foreign import ccall unsafe "HsBase.h __hscore_fd_cloexec"   const_fd_cloexec :: CLong--#if defined(HTYPE_TCFLAG_T)-foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios"  sizeof_termios :: Int-foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int--foreign import ccall unsafe "HsBase.h __hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag-foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()-foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)-#endif--s_issock :: CMode -> Bool-#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-s_issock _ = False-#endif--foreign import ccall unsafe "__hscore_bufsiz"  dEFAULT_BUFFER_SIZE :: Int-foreign import capi  unsafe "stdio.h value SEEK_CUR" sEEK_CUR :: CInt-foreign import capi  unsafe "stdio.h value SEEK_SET" sEEK_SET :: CInt-foreign import capi  unsafe "stdio.h value SEEK_END" sEEK_END :: CInt--{--Note: Windows types--Windows' _read and _write have types that differ from POSIX. They take an-unsigned int for length and return a signed int where POSIX uses size_t and-ssize_t. Those are different on x86_64 and equivalent on x86. We import them-with the types in Microsoft's documentation which means that c_read,-c_safe_read, c_write and c_safe_write have different Haskell types depending on-the OS.--}-
− System/Posix/Types.hs 
@@ -1,254 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Trustworthy #-}---------------------------------------------------------------------------------- |--- Module      :  System.Posix.Types--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (requires POSIX)------ POSIX data types: Haskell equivalents of the types defined by the--- @\<sys\/types.h>@ C header on a POSIX system.----------------------------------------------------------------------------------#include "HsBaseConfig.h"--module System.Posix.Types (--  -- * POSIX data types--  -- ** Platform differences-  -- | This module contains platform specific information about types.-  --   __/As such the types presented on this page reflect the platform-  --   on which the documentation was generated and may not coincide with-  --   the types on your platform./__-#if defined(HTYPE_DEV_T)-  CDev(..),-#endif-#if defined(HTYPE_INO_T)-  CIno(..),-#endif-#if defined(HTYPE_MODE_T)-  CMode(..),-#endif-#if defined(HTYPE_OFF_T)-  COff(..),-#endif-#if defined(HTYPE_PID_T)-  CPid(..),-#endif-#if defined(HTYPE_SSIZE_T)-  CSsize(..),-#endif--#if defined(HTYPE_GID_T)-  CGid(..),-#endif-#if defined(HTYPE_NLINK_T)-  CNlink(..),-#endif-#if defined(HTYPE_UID_T)-  CUid(..),-#endif-#if defined(HTYPE_CC_T)-  CCc(..),-#endif-#if defined(HTYPE_SPEED_T)-  CSpeed(..),-#endif-#if defined(HTYPE_TCFLAG_T)-  CTcflag(..),-#endif-#if defined(HTYPE_RLIM_T)-  CRLim(..),-#endif-#if defined(HTYPE_BLKSIZE_T)-  CBlkSize(..),-#endif-#if defined(HTYPE_BLKCNT_T)-  CBlkCnt(..),-#endif-#if defined(HTYPE_CLOCKID_T)-  CClockId(..),-#endif-#if defined(HTYPE_FSBLKCNT_T)-  CFsBlkCnt(..),-#endif-#if defined(HTYPE_FSFILCNT_T)-  CFsFilCnt(..),-#endif-#if defined(HTYPE_ID_T)-  CId(..),-#endif-#if defined(HTYPE_KEY_T)-  CKey(..),-#endif-#if defined(HTYPE_TIMER_T)-  CTimer(..),-#endif-#if defined(HTYPE_SOCKLEN_T)-  CSocklen(..),-#endif-#if defined(HTYPE_NFDS_T)-  CNfds(..),-#endif--  Fd(..),--  -- See Note [Exporting constructors of marshallable foreign types]-  -- in Foreign.Ptr for why the constructors for these newtypes are-  -- exported.--#if defined(HTYPE_NLINK_T)-  LinkCount,-#endif-#if defined(HTYPE_UID_T)-  UserID,-#endif-#if defined(HTYPE_GID_T)-  GroupID,-#endif--  ByteCount,-  ClockTick,-  EpochTime,-  FileOffset,-  ProcessID,-  ProcessGroupID,-  DeviceID,-  FileID,-  FileMode,-  Limit- ) where--import Foreign-import Foreign.C--- import Data.Bits--import GHC.Base-import GHC.Enum-import GHC.Ix-import GHC.Num-import GHC.Read-import GHC.Real--- import GHC.Prim-import GHC.Show--#include "CTypes.h"--#if defined(HTYPE_DEV_T)-INTEGRAL_TYPE(CDev,"dev_t",HTYPE_DEV_T)-#endif-#if defined(HTYPE_INO_T)-INTEGRAL_TYPE(CIno,"ino_t",HTYPE_INO_T)-#endif-#if defined(HTYPE_MODE_T)-INTEGRAL_TYPE(CMode,"mode_t",HTYPE_MODE_T)-#endif-#if defined(HTYPE_OFF_T)-INTEGRAL_TYPE(COff,"off_t",HTYPE_OFF_T)-#endif-#if defined(HTYPE_PID_T)-INTEGRAL_TYPE(CPid,"pid_t",HTYPE_PID_T)-#endif--#if defined(HTYPE_SSIZE_T)-INTEGRAL_TYPE(CSsize,"ssize_t",HTYPE_SSIZE_T)-#endif--#if defined(HTYPE_GID_T)-INTEGRAL_TYPE(CGid,"gid_t",HTYPE_GID_T)-#endif-#if defined(HTYPE_NLINK_T)-INTEGRAL_TYPE(CNlink,"nlink_t",HTYPE_NLINK_T)-#endif--#if defined(HTYPE_UID_T)-INTEGRAL_TYPE(CUid,"uid_t",HTYPE_UID_T)-#endif-#if defined(HTYPE_CC_T)-ARITHMETIC_TYPE(CCc,"cc_t",HTYPE_CC_T)-#endif-#if defined(HTYPE_SPEED_T)-ARITHMETIC_TYPE(CSpeed,"speed_t",HTYPE_SPEED_T)-#endif-#if defined(HTYPE_TCFLAG_T)-INTEGRAL_TYPE(CTcflag,"tcflag_t",HTYPE_TCFLAG_T)-#endif-#if defined(HTYPE_RLIM_T)-INTEGRAL_TYPE(CRLim,"rlim_t",HTYPE_RLIM_T)-#endif--#if defined(HTYPE_BLKSIZE_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CBlkSize,"blksize_t",HTYPE_BLKSIZE_T)-#endif-#if defined(HTYPE_BLKCNT_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CBlkCnt,"blkcnt_t",HTYPE_BLKCNT_T)-#endif-#if defined(HTYPE_CLOCKID_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CClockId,"clockid_t",HTYPE_CLOCKID_T)-#endif-#if defined(HTYPE_FSBLKCNT_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CFsBlkCnt,"fsblkcnt_t",HTYPE_FSBLKCNT_T)-#endif-#if defined(HTYPE_FSFILCNT_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CFsFilCnt,"fsfilcnt_t",HTYPE_FSFILCNT_T)-#endif-#if defined(HTYPE_ID_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CId,"id_t",HTYPE_ID_T)-#endif-#if defined(HTYPE_KEY_T)--- | @since 4.10.0.0-INTEGRAL_TYPE(CKey,"key_t",HTYPE_KEY_T)-#endif-#if defined(HTYPE_TIMER_T)--- | @since 4.10.0.0-OPAQUE_TYPE(CTimer,"timer_t",HTYPE_TIMER_T)-#endif--#if defined(HTYPE_SOCKLEN_T)--- | @since 4.14.0.0-INTEGRAL_TYPE(CSocklen,"socklen_t",HTYPE_SOCKLEN_T)-#endif-#if defined(HTYPE_NFDS_T)--- | @since 4.14.0.0-INTEGRAL_TYPE(CNfds,"nfds_t",HTYPE_NFDS_T)-#endif---- Make an Fd type rather than using CInt everywhere-INTEGRAL_TYPE(Fd,"int",CInt)---- nicer names, and backwards compatibility with POSIX library:-#if defined(HTYPE_NLINK_T)-type LinkCount      = CNlink-#endif-#if defined(HTYPE_UID_T)-type UserID         = CUid-#endif-#if defined(HTYPE_GID_T)-type GroupID        = CGid-#endif--type ByteCount      = CSize-type ClockTick      = CClock-type EpochTime      = CTime-type DeviceID       = CDev-type FileID         = CIno-type FileMode       = CMode-type ProcessID      = CPid-type FileOffset     = COff-type ProcessGroupID = CPid-type Limit          = CLong
− System/Timeout.hs 
@@ -1,140 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}------------------------------------------------------------------------------------ |--- Module      :  System.Timeout--- Copyright   :  (c) The University of Glasgow 2007--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Attach a timeout event to arbitrary 'IO' computations.-------------------------------------------------------------------------------------- TODO: Inspect is still suitable.-module System.Timeout ( Timeout, timeout ) where--#if !defined(mingw32_HOST_OS)-import Control.Monad-import GHC.Event           (getSystemTimerManager,-                            registerTimeout, unregisterTimeout)-#endif--import Control.Concurrent-import Control.Exception   (Exception(..), handleJust, bracket,-                            uninterruptibleMask_,-                            asyncExceptionToException,-                            asyncExceptionFromException)-import Data.Unique         (Unique, newUnique)---- $setup--- >>> import Prelude--- >>> import Control.Concurrent (threadDelay)---- An internal type that is thrown as a dynamic exception to--- interrupt the running IO computation when the timeout has--- expired.---- | An exception thrown to a thread by 'timeout' to interrupt a timed-out--- computation.------ @since 4.0-newtype Timeout = Timeout Unique deriving Eq---- | @since 4.0-instance Show Timeout where-    show _ = "<<timeout>>"---- Timeout is a child of SomeAsyncException--- | @since 4.7.0.0-instance Exception Timeout where-  toException = asyncExceptionToException-  fromException = asyncExceptionFromException---- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result--- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result--- is available before the timeout expires, @Just a@ is returned. A negative--- timeout interval means \"wait indefinitely\". When specifying long timeouts,--- be careful not to exceed @maxBound :: Int@.------ >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time")--- Just "finished on time"------ >>> timeout 10000 (threadDelay 100000 *> pure "finished on time")--- Nothing------ The design of this combinator was guided by the objective that @timeout n f@--- should behave exactly the same as @f@ as long as @f@ doesn't time out. This--- means that @f@ has the same 'myThreadId' it would have without the timeout--- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate--- further up. It also possible for @f@ to receive exceptions thrown to it by--- another thread.------ A tricky implementation detail is the question of how to abort an @IO@--- computation. This combinator relies on asynchronous exceptions internally--- (namely throwing the computation the 'Timeout' exception).  The technique--- works very well for computations executing inside of the Haskell runtime--- system, but it doesn't work at all for non-Haskell code.  Foreign function--- calls, for example, cannot be timed out with this combinator simply because--- an arbitrary C function cannot receive asynchronous exceptions. When--- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be--- delivered until the FFI call returns, which pretty much negates the purpose--- of the combinator. In practice, however, this limitation is less severe than--- it may sound. Standard I\/O functions like 'System.IO.hGetBuf',--- 'System.IO.hPutBuf', Network.Socket.accept, or 'System.IO.hWaitForInput'--- appear to be blocking, but they really don't because the runtime system uses--- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it--- is possible to interrupt standard socket I\/O or file I\/O using this--- combinator.------- Note that 'timeout' cancels the computation by throwing it the 'Timeout'--- exception. Consequently blanket exception handlers (e.g. catching--- 'SomeException') within the computation will break the timeout behavior.-timeout :: Int -> IO a -> IO (Maybe a)-timeout n f-    | n <  0    = fmap Just f-    | n == 0    = return Nothing-#if !defined(mingw32_HOST_OS)-    | rtsSupportsBoundThreads = do-        -- In the threaded RTS, we use the Timer Manager to delay the-        -- (fairly expensive) 'forkIO' call until the timeout has expired.-        ---        -- An additional thread is required for the actual delivery of-        -- the Timeout exception because killThread (or another throwTo)-        -- is the only way to reliably interrupt a throwTo in flight.-        pid <- myThreadId-        ex  <- fmap Timeout newUnique-        tm  <- getSystemTimerManager-        -- 'lock' synchronizes the timeout handler and the main thread:-        --  * the main thread can disable the handler by writing to 'lock';-        --  * the handler communicates the spawned thread's id through 'lock'.-        -- These two cases are mutually exclusive.-        lock <- newEmptyMVar-        let handleTimeout = do-                v <- isEmptyMVar lock-                when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do-                    v2 <- tryPutMVar lock =<< myThreadId-                    when v2 $ throwTo pid ex-            cleanupTimeout key = uninterruptibleMask_ $ do-                v <- tryPutMVar lock undefined-                if v then unregisterTimeout tm key-                     else takeMVar lock >>= killThread-        handleJust (\e -> if e == ex then Just () else Nothing)-                   (\_ -> return Nothing)-                   (bracket (registerTimeout tm n handleTimeout)-                            cleanupTimeout-                            (\_ -> fmap Just f))-#endif-    | otherwise = do-        pid <- myThreadId-        ex  <- fmap Timeout newUnique-        handleJust (\e -> if e == ex then Just () else Nothing)-                   (\_ -> return Nothing)-                   (bracket (forkIOWithUnmask $ \unmask ->-                                 unmask $ threadDelay n >> throwTo pid ex)-                            (uninterruptibleMask_ . killThread)-                            (\_ -> fmap Just f))-        -- #7719 explains why we need uninterruptibleMask_ above.
− Text/ParserCombinators/ReadP.hs 
@@ -1,504 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE DeriveFunctor #-}---------------------------------------------------------------------------------- |--- Module      :  Text.ParserCombinators.ReadP--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (local universal quantification)------ This is a library of parser combinators, originally written by Koen Claessen.--- It parses all alternatives in parallel, so it never keeps hold of--- the beginning of the input string, a common source of space leaks with--- other parsers.  The @('+++')@ choice combinator is genuinely commutative;--- it makes no difference which branch is \"shorter\".---------------------------------------------------------------------------------module Text.ParserCombinators.ReadP-  (-  -- * The 'ReadP' type-  ReadP,--  -- * Primitive operations-  get,-  look,-  (+++),-  (<++),-  gather,--  -- * Other operations-  pfail,-  eof,-  satisfy,-  char,-  string,-  munch,-  munch1,-  skipSpaces,-  choice,-  count,-  between,-  option,-  optional,-  many,-  many1,-  skipMany,-  skipMany1,-  sepBy,-  sepBy1,-  endBy,-  endBy1,-  chainr,-  chainl,-  chainl1,-  chainr1,-  manyTill,--  -- * Running a parser-  ReadS,-  readP_to_S,-  readS_to_P,--  -- * Properties-  -- $properties-  )- where--import GHC.Unicode ( isSpace )-import GHC.List ( replicate, null )-import GHC.Base hiding ( many )--import Control.Monad.Fail--infixr 5 +++, <++----------------------------------------------------------------------------- ReadS---- | A parser for a type @a@, represented as a function that takes a--- 'String' and returns a list of possible parses as @(a,'String')@ pairs.------ Note that this kind of backtracking parser is very inefficient;--- reading a large structure may be quite slow (cf 'ReadP').-type ReadS a = String -> [(a,String)]---- ------------------------------------------------------------------------------ The P type--- is representation type -- should be kept abstract--data P a-  = Get (Char -> P a)-  | Look (String -> P a)-  | Fail-  | Result a (P a)-  | Final (NonEmpty (a,String))-  deriving Functor -- ^ @since 4.8.0.0---- Monad, MonadPlus---- | @since 4.5.0.0-instance Applicative P where-  pure x = Result x Fail-  (<*>) = ap---- | @since 2.01-instance MonadPlus P---- | @since 2.01-instance Monad P where-  (Get f)         >>= k = Get (\c -> f c >>= k)-  (Look f)        >>= k = Look (\s -> f s >>= k)-  Fail            >>= _ = Fail-  (Result x p)    >>= k = k x <|> (p >>= k)-  (Final (r:|rs)) >>= k = final [ys' | (x,s) <- (r:rs), ys' <- run (k x) s]---- | @since 4.9.0.0-instance MonadFail P where-  fail _ = Fail---- | @since 4.5.0.0-instance Alternative P where-  empty = Fail--  -- most common case: two gets are combined-  Get f1     <|> Get f2     = Get (\c -> f1 c <|> f2 c)--  -- results are delivered as soon as possible-  Result x p <|> q          = Result x (p <|> q)-  p          <|> Result x q = Result x (p <|> q)--  -- fail disappears-  Fail       <|> p          = p-  p          <|> Fail       = p--  -- two finals are combined-  -- final + look becomes one look and one final (=optimization)-  -- final + sthg else becomes one look and one final-  Final r       <|> Final t = Final (r <> t)-  Final (r:|rs) <|> Look f  = Look (\s -> Final (r:|(rs ++ run (f s) s)))-  Final (r:|rs) <|> p       = Look (\s -> Final (r:|(rs ++ run p s)))-  Look f        <|> Final r = Look (\s -> Final (case run (f s) s of-                                []     -> r-                                (x:xs) -> (x:|xs) <> r))-  p             <|> Final r = Look (\s -> Final (case run p s of-                                []     -> r-                                (x:xs) -> (x:|xs) <> r))--  -- two looks are combined (=optimization)-  -- look + sthg else floats upwards-  Look f     <|> Look g     = Look (\s -> f s <|> g s)-  Look f     <|> p          = Look (\s -> f s <|> p)-  p          <|> Look f     = Look (\s -> p <|> f s)---- ------------------------------------------------------------------------------ The ReadP type--newtype ReadP a = R (forall b . (a -> P b) -> P b)---- | @since 2.01-instance Functor ReadP where-  fmap h (R f) = R (\k -> f (k . h))---- | @since 4.6.0.0-instance Applicative ReadP where-    pure x = R (\k -> k x)-    (<*>) = ap-    -- liftA2 = liftM2---- | @since 2.01-instance Monad ReadP where-  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))---- | @since 4.9.0.0-instance MonadFail ReadP where-  fail _    = R (\_ -> Fail)---- | @since 4.6.0.0-instance Alternative ReadP where-  empty = pfail-  (<|>) = (+++)---- | @since 2.01-instance MonadPlus ReadP---- ------------------------------------------------------------------------------ Operations over P--final :: [(a,String)] -> P a-final []     = Fail-final (r:rs) = Final (r:|rs)--run :: P a -> ReadS a-run (Get f)         (c:s) = run (f c) s-run (Look f)        s     = run (f s) s-run (Result x p)    s     = (x,s) : run p s-run (Final (r:|rs)) _     = (r:rs)-run _               _     = []---- ------------------------------------------------------------------------------ Operations over ReadP--get :: ReadP Char--- ^ Consumes and returns the next character.---   Fails if there is no input left.-get = R Get--look :: ReadP String--- ^ Look-ahead: returns the part of the input that is left, without---   consuming it.-look = R Look--pfail :: ReadP a--- ^ Always fails.-pfail = R (\_ -> Fail)--(+++) :: ReadP a -> ReadP a -> ReadP a--- ^ Symmetric choice.-R f1 +++ R f2 = R (\k -> f1 k <|> f2 k)--(<++) :: ReadP a -> ReadP a -> ReadP a--- ^ Local, exclusive, left-biased choice: If left parser---   locally produces any result at all, then right parser is---   not used.-R f0 <++ q =-  do s <- look-     probe (f0 return) s 0#- where-  probe (Get f)        (c:s) n = probe (f c) s (n+#1#)-  probe (Look f)       s     n = probe (f s) s n-  probe p@(Result _ _) _     n = discard n >> R (p >>=)-  probe (Final r)      _     _ = R (Final r >>=)-  probe _              _     _ = q--  discard 0# = return ()-  discard n  = get >> discard (n-#1#)--gather :: ReadP a -> ReadP (String, a)--- ^ Transforms a parser into one that does the same, but---   in addition returns the exact characters read.---   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument---   is built using any occurrences of readS_to_P.-gather (R m)-  = R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))- where-  gath :: (String -> String) -> P (String -> P b) -> P b-  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))-  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 _)    = errorWithoutStackTrace "do not use readS_to_P in gather!"---- ------------------------------------------------------------------------------ Derived operations--satisfy :: (Char -> Bool) -> ReadP Char--- ^ Consumes and returns the next character, if it satisfies the---   specified predicate.-satisfy p = do c <- get; if p c then return c else pfail--char :: Char -> ReadP Char--- ^ Parses and returns the specified character.-char c = satisfy (c ==)--eof :: ReadP ()--- ^ Succeeds iff we are at the end of input-eof = do { s <- look-         ; if null s then return ()-                     else pfail }--string :: String -> ReadP String--- ^ Parses and returns the specified string.-string this = do s <- look; scan this s- where-  scan []     _               = return this-  scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys-  scan _      _               = pfail--munch :: (Char -> Bool) -> ReadP String--- ^ Parses the first zero or more characters satisfying the predicate.---   Always succeeds, exactly once having consumed all the characters---   Hence NOT the same as (many (satisfy p))-munch p =-  do s <- look-     scan s- where-  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)-  scan _            = return ""--munch1 :: (Char -> Bool) -> ReadP String--- ^ Parses the first one or more characters satisfying the predicate.---   Fails if none, else succeeds exactly once having consumed all the characters---   Hence NOT the same as (many1 (satisfy p))-munch1 p =-  do c <- get-     if p c then do s <- munch p; return (c:s)-            else pfail--choice :: [ReadP a] -> ReadP a--- ^ Combines all parsers in the specified list.-choice []     = pfail-choice [p]    = p-choice (p:ps) = p +++ choice ps--skipSpaces :: ReadP ()--- ^ Skips all whitespace.-skipSpaces =-  do s <- look-     skip s- where-  skip (c:s) | isSpace c = do _ <- get; skip s-  skip _                 = return ()--count :: Int -> ReadP a -> ReadP [a]--- ^ @count n p@ parses @n@ occurrences of @p@ in sequence. A list of---   results is returned.-count n p = sequence (replicate n p)--between :: ReadP open -> ReadP close -> ReadP a -> ReadP a--- ^ @between open close p@ parses @open@, followed by @p@ and finally---   @close@. Only the value of @p@ is returned.-between open close p = do _ <- open-                          x <- p-                          _ <- close-                          return x--option :: a -> ReadP a -> ReadP a--- ^ @option x p@ will either parse @p@ or return @x@ without consuming---   any input.-option x p = p +++ return x--optional :: ReadP a -> ReadP ()--- ^ @optional p@ optionally parses @p@ and always returns @()@.-optional p = (p >> return ()) +++ return ()--many :: ReadP a -> ReadP [a]--- ^ Parses zero or more occurrences of the given parser.-many p = return [] +++ many1 p--many1 :: ReadP a -> ReadP [a]--- ^ Parses one or more occurrences of the given parser.-many1 p = liftM2 (:) p (many p)--skipMany :: ReadP a -> ReadP ()--- ^ Like 'many', but discards the result.-skipMany p = many p >> return ()--skipMany1 :: ReadP a -> ReadP ()--- ^ Like 'many1', but discards the result.-skipMany1 p = p >> skipMany p--sepBy :: ReadP a -> ReadP sep -> ReadP [a]--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy p sep = sepBy1 p sep +++ return []--sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy1 p sep = liftM2 (:) p (many (sep >> p))--endBy :: ReadP a -> ReadP sep -> ReadP [a]--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended---   by @sep@.-endBy p sep = many (do x <- p ; _ <- sep ; return x)--endBy1 :: ReadP a -> ReadP sep -> ReadP [a]--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended---   by @sep@.-endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)--chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /right/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainr p op x = chainr1 p op +++ return x--chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /left/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainl p op x = chainl1 p op +++ return x--chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a--- ^ Like 'chainr', but parses one or more occurrences of @p@.-chainr1 p op = scan-  where scan   = p >>= rest-        rest x = do f <- op-                    y <- scan-                    return (f x y)-                 +++ return x--chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a--- ^ Like 'chainl', but parses one or more occurrences of @p@.-chainl1 p op = p >>= rest-  where rest x = do f <- op-                    y <- p-                    rest (f x y)-                 +++ return x--manyTill :: ReadP a -> ReadP end -> ReadP [a]--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@---   succeeds. Returns a list of values returned by @p@.-manyTill p end = scan-  where scan = (end >> return []) <++ (liftM2 (:) p scan)---- ------------------------------------------------------------------------------ Converting between ReadP and Read--readP_to_S :: ReadP a -> ReadS a--- ^ Converts a parser into a Haskell ReadS-style function.---   This is the main way in which you can \"run\" a 'ReadP' parser:---   the expanded type is--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @-readP_to_S (R f) = run (f return)--readS_to_P :: ReadS a -> ReadP a--- ^ Converts a Haskell ReadS-style function into a parser.---   Warning: This introduces local backtracking in the resulting---   parser, and therefore a possible inefficiency.-readS_to_P r =-  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))---- ------------------------------------------------------------------------------ QuickCheck properties that hold for the combinators--{- $properties-The following are QuickCheck specifications of what the combinators do.-These can be seen as formal specifications of the behavior of the-combinators.--For some values, we only care about the lists contents, not their order,--> (=~) :: Ord a => [a] -> [a] -> Bool-> xs =~ ys = sort xs == sort ys--Here follow the properties:-->>> readP_to_S get []-[]--prop> \c str -> readP_to_S get (c:str) == [(c, str)]--prop> \str -> readP_to_S look str == [(str, str)]--prop> \str -> readP_to_S pfail str == []--prop> \x str -> readP_to_S (return x) s == [(x,s)]--> prop_Bind p k s =->    readP_to_S (p >>= k) s =~->      [ ys''->      | (x,s') <- readP_to_S p s->      , ys''   <- readP_to_S (k (x::Int)) s'->      ]--> prop_Plus p q s =->   readP_to_S (p +++ q) s =~->     (readP_to_S p s ++ readP_to_S q s)--> prop_LeftPlus p q s =->   readP_to_S (p <++ q) s =~->     (readP_to_S p s +<+ readP_to_S q s)->  where->   [] +<+ ys = ys->   xs +<+ _  = xs--> prop_Gather s =->   forAll readPWithoutReadS $ \p ->->     readP_to_S (gather p) s =~->       [ ((pre,x::Int),s')->       | (x,s') <- readP_to_S p s->       , let pre = take (length s - length s') s->       ]--prop> \this str -> readP_to_S (string this) (this ++ str) == [(this,str)]--> prop_String_Maybe this s =->   readP_to_S (string this) s =~->     [(this, drop (length this) s) | this `isPrefixOf` s]--> prop_Munch p s =->   readP_to_S (munch p) s =~->     [(takeWhile p s, dropWhile p s)]--> prop_Munch1 p s =->   readP_to_S (munch1 p) s =~->     [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]--> prop_Choice ps s =->   readP_to_S (choice ps) s =~->     readP_to_S (foldr (+++) pfail ps) s--> prop_ReadS r s =->   readP_to_S (readS_to_P r) s =~ r s--}
− Text/ParserCombinators/ReadPrec.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Text.ParserCombinators.ReadPrec--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (uses Text.ParserCombinators.ReadP)------ This library defines parser combinators for precedence parsing.---------------------------------------------------------------------------------module Text.ParserCombinators.ReadPrec-  (-  ReadPrec,--  -- * Precedences-  Prec,-  minPrec,--  -- * Precedence operations-  lift,-  prec,-  step,-  reset,--  -- * Other operations-  -- | All are based directly on their similarly-named 'ReadP' counterparts.-  get,-  look,-  (+++),-  (<++),-  pfail,-  choice,--  -- * Converters-  readPrec_to_P,-  readP_to_Prec,-  readPrec_to_S,-  readS_to_Prec,-  )- where---import Text.ParserCombinators.ReadP-  ( ReadP-  , ReadS-  , readP_to_S-  , readS_to_P-  )--import qualified Text.ParserCombinators.ReadP as ReadP-  ( get-  , look-  , (+++), (<++)-  , pfail-  )--import GHC.Num( Num(..) )-import GHC.Base--import Control.Monad.Fail---- ------------------------------------------------------------------------------ The readPrec type--newtype ReadPrec a = P (Prec -> ReadP a)---- Functor, Monad, MonadPlus---- | @since 2.01-instance Functor ReadPrec where-  fmap h (P f) = P (\n -> fmap h (f n))---- | @since 4.6.0.0-instance Applicative ReadPrec where-    pure x  = P (\_ -> pure x)-    (<*>) = ap-    liftA2 = liftM2---- | @since 2.01-instance Monad ReadPrec where-  P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)---- | @since 4.9.0.0-instance MonadFail ReadPrec where-  fail s    = P (\_ -> fail s)---- | @since 2.01-instance MonadPlus ReadPrec---- | @since 4.6.0.0-instance Alternative ReadPrec where-  empty = pfail-  (<|>) = (+++)---- precedences-type Prec = Int--minPrec :: Prec-minPrec = 0---- ------------------------------------------------------------------------------ Operations over ReadPrec--lift :: ReadP a -> ReadPrec a--- ^ Lift a precedence-insensitive 'ReadP' to a 'ReadPrec'.-lift m = P (\_ -> m)--step :: ReadPrec a -> ReadPrec a--- ^ Increases the precedence context by one.-step (P f) = P (\n -> f (n+1))--reset :: ReadPrec a -> ReadPrec a--- ^ Resets the precedence context to zero.-reset (P f) = P (\_ -> f minPrec)--prec :: Prec -> ReadPrec a -> ReadPrec a--- ^ @(prec n p)@ checks whether the precedence context is---   less than or equal to @n@, and------   * if not, fails------   * if so, parses @p@ in context @n@.-prec n (P f) = P (\c -> if c <= n then f n else ReadP.pfail)---- ------------------------------------------------------------------------------ Derived operations--get :: ReadPrec Char--- ^ Consumes and returns the next character.---   Fails if there is no input left.-get = lift ReadP.get--look :: ReadPrec String--- ^ Look-ahead: returns the part of the input that is left, without---   consuming it.-look = lift ReadP.look--(+++) :: ReadPrec a -> ReadPrec a -> ReadPrec a--- ^ Symmetric choice.-P f1 +++ P f2 = P (\n -> f1 n ReadP.+++ f2 n)--(<++) :: ReadPrec a -> ReadPrec a -> ReadPrec a--- ^ Local, exclusive, left-biased choice: If left parser---   locally produces any result at all, then right parser is---   not used.-P f1 <++ P f2 = P (\n -> f1 n ReadP.<++ f2 n)--pfail :: ReadPrec a--- ^ Always fails.-pfail = lift ReadP.pfail--choice :: [ReadPrec a] -> ReadPrec a--- ^ Combines all parsers in the specified list.-choice ps = foldr (+++) pfail ps---- ------------------------------------------------------------------------------ Converting between ReadPrec and Read--readPrec_to_P :: ReadPrec a -> (Int -> ReadP a)-readPrec_to_P (P f) = f--readP_to_Prec :: (Int -> ReadP a) -> ReadPrec a-readP_to_Prec f = P f--readPrec_to_S :: ReadPrec a -> (Int -> ReadS a)-readPrec_to_S (P f) n = readP_to_S (f n)--readS_to_Prec :: (Int -> ReadS a) -> ReadPrec a-readS_to_Prec f = P (\n -> readS_to_P (f n))-
− Text/Printf.hs 
@@ -1,918 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---------------------------------------------------------------------------------- |--- Module      :  Text.Printf--- Copyright   :  (c) Lennart Augustsson and Bart Massey 2013--- License     :  BSD-style (see the file LICENSE in this distribution)------ Maintainer  :  Bart Massey <bart@cs.pdx.edu>--- Stability   :  provisional--- Portability :  portable------ A C @printf(3)@-like formatter. This version has been--- extended by Bart Massey as per the recommendations of--- John Meacham and Simon Marlow--- <http://comments.gmane.org/gmane.comp.lang.haskell.libraries/4726>--- to support extensible formatting for new datatypes.  It--- has also been extended to support almost all C--- @printf(3)@ syntax.--------------------------------------------------------------------------------module Text.Printf(--- * Printing Functions-   printf, hPrintf,--- * Extending To New Types------ | This 'printf' can be extended to format types--- other than those provided for by default. This--- is done by instantiating 'PrintfArg' and providing--- a 'formatArg' for the type. It is possible to--- provide a 'parseFormat' to process type-specific--- modifiers, but the default instance is usually--- the best choice.------ For example:------ > instance PrintfArg () where--- >   formatArg x fmt | fmtChar (vFmt 'U' fmt) == 'U' =--- >     formatString "()" (fmt { fmtChar = 's', fmtPrecision = Nothing })--- >   formatArg _ fmt = errorBadFormat $ fmtChar fmt--- >--- > main :: IO ()--- > main = printf "[%-3.1U]\n" ()------ prints \"@[() ]@\". Note the use of 'formatString' to--- take care of field formatting specifications in a convenient--- way.-   PrintfArg(..),-   FieldFormatter,-   FieldFormat(..),-   FormatAdjustment(..), FormatSign(..),-   vFmt,--- ** Handling Type-specific Modifiers------ | In the unlikely case that modifier characters of--- some kind are desirable for a user-provided type,--- a 'ModifierParser' can be provided to process these--- characters. The resulting modifiers will appear in--- the 'FieldFormat' for use by the type-specific formatter.-   ModifierParser, FormatParse(..),--- ** Standard Formatters------ | These formatters for standard types are provided for--- convenience in writting new type-specific formatters:--- a common pattern is to throw to 'formatString' or--- 'formatInteger' to do most of the format handling for--- a new type.-   formatString, formatChar, formatInt,-   formatInteger, formatRealFloat,--- ** Raising Errors------ | These functions are used internally to raise various--- errors, and are exported for use by new type-specific--- formatters.-  errorBadFormat, errorShortFormat, errorMissingArgument,-  errorBadArgument,-  perror,--- * Implementation Internals--- | These types are needed for implementing processing--- variable numbers of arguments to 'printf' and 'hPrintf'.--- Their implementation is intentionally not visible from--- this module. If you attempt to pass an argument of a type--- which is not an instance of the appropriate class to--- 'printf' or 'hPrintf', then the compiler will report it--- as a missing instance of 'PrintfArg'.  (All 'PrintfArg'--- instances are 'PrintfType' instances.)-  PrintfType, HPrintfType,--- | This class is needed as a Haskell98 compatibility--- workaround for the lack of FlexibleInstances.-  IsChar(..)-) where--import Data.Char-import Data.Int-import Data.List (stripPrefix)-import Data.Word-import Numeric-import Numeric.Natural-import System.IO---- $setup--- >>> import Prelude------------------------- | Format a variable number of arguments with the C-style formatting string.------ >>> printf "%s, %d, %.4f" "hello" 123 pi--- hello, 123, 3.1416------ The return value is either 'String' or @('IO' a)@ (which--- should be @('IO' ())@, but Haskell's type system--- makes this hard).------ The format string consists of ordinary characters and--- /conversion specifications/, which specify how to format--- one of the arguments to 'printf' in the output string. A--- format specification is introduced by the @%@ character;--- this character can be self-escaped into the format string--- using @%%@. A format specification ends with a--- /format character/ that provides the primary information about--- how to format the value. The rest of the conversion--- specification is optional.  In order, one may have flag--- characters, a width specifier, a precision specifier, and--- type-specific modifier characters.------ Unlike C @printf(3)@, the formatting of this 'printf'--- is driven by the argument type; formatting is type specific. The--- types formatted by 'printf' \"out of the box\" are:------   * 'Integral' types, including 'Char'------   * 'String'------   * 'RealFloat' types------ 'printf' is also extensible to support other types: see below.------ A conversion specification begins with the--- character @%@, followed by zero or more of the following flags:------ > -      left adjust (default is right adjust)--- > +      always use a sign (+ or -) for signed conversions--- > space  leading space for positive numbers in signed conversions--- > 0      pad with zeros rather than spaces--- > #      use an \"alternate form\": see below------ When both flags are given, @-@ overrides @0@ and @+@ overrides space.--- A negative width specifier in a @*@ conversion is treated as--- positive but implies the left adjust flag.------ The \"alternate form\" for unsigned radix conversions is--- as in C @printf(3)@:------ > %o           prefix with a leading 0 if needed--- > %x           prefix with a leading 0x if nonzero--- > %X           prefix with a leading 0X if nonzero--- > %b           prefix with a leading 0b if nonzero--- > %[eEfFgG]    ensure that the number contains a decimal point------ Any flags are followed optionally by a field width:------ > num    field width--- > *      as num, but taken from argument list------ The field width is a minimum, not a maximum: it will be--- expanded as needed to avoid mutilating a value.------ Any field width is followed optionally by a precision:------ > .num   precision--- > .      same as .0--- > .*     as num, but taken from argument list------ Negative precision is taken as 0. The meaning of the--- precision depends on the conversion type.------ > Integral    minimum number of digits to show--- > RealFloat   number of digits after the decimal point--- > String      maximum number of characters------ The precision for Integral types is accomplished by zero-padding.--- If both precision and zero-pad are given for an Integral field,--- the zero-pad is ignored.------ Any precision is followed optionally for Integral types--- by a width modifier; the only use of this modifier being--- to set the implicit size of the operand for conversion of--- a negative operand to unsigned:------ > hh     Int8--- > h      Int16--- > l      Int32--- > ll     Int64--- > L      Int64------ The specification ends with a format character:------ > c      character               Integral--- > d      decimal                 Integral--- > o      octal                   Integral--- > x      hexadecimal             Integral--- > X      hexadecimal             Integral--- > b      binary                  Integral--- > u      unsigned decimal        Integral--- > f      floating point          RealFloat--- > F      floating point          RealFloat--- > g      general format float    RealFloat--- > G      general format float    RealFloat--- > e      exponent format float   RealFloat--- > E      exponent format float   RealFloat--- > s      string                  String--- > v      default format          any type------ The \"%v\" specifier is provided for all built-in types,--- and should be provided for user-defined type formatters--- as well. It picks a \"best\" representation for the given--- type. For the built-in types the \"%v\" specifier is--- converted as follows:------ > c      Char--- > u      other unsigned Integral--- > d      other signed Integral--- > g      RealFloat--- > s      String------ Mismatch between the argument types and the format--- string, as well as any other syntactic or semantic errors--- in the format string, will cause an exception to be--- thrown at runtime.------ Note that the formatting for 'RealFloat' types is--- currently a bit different from that of C @printf(3)@,--- conforming instead to 'Numeric.showEFloat',--- 'Numeric.showFFloat' and 'Numeric.showGFloat' (and their--- alternate versions 'Numeric.showFFloatAlt' and--- 'Numeric.showGFloatAlt'). This is hard to fix: the fixed--- versions would format in a backward-incompatible way.--- In any case the Haskell behavior is generally more--- sensible than the C behavior.  A brief summary of some--- key differences:------ * Haskell 'printf' never uses the default \"6-digit\" precision---   used by C printf.------ * Haskell 'printf' treats the \"precision\" specifier as---   indicating the number of digits after the decimal point.------ * Haskell 'printf' prints the exponent of e-format---   numbers without a gratuitous plus sign, and with the---   minimum possible number of digits.------ * Haskell 'printf' will place a zero after a decimal point when---   possible.-printf :: (PrintfType r) => String -> r-printf fmts = spr fmts []---- | Similar to 'printf', except that output is via the specified--- 'Handle'.  The return type is restricted to @('IO' a)@.-hPrintf :: (HPrintfType r) => Handle -> String -> r-hPrintf hdl fmts = hspr hdl fmts []---- |The 'PrintfType' class provides the variable argument magic for--- 'printf'.  Its implementation is intentionally not visible from--- this module. If you attempt to pass an argument of a type which--- is not an instance of this class to 'printf' or 'hPrintf', then--- the compiler will report it as a missing instance of 'PrintfArg'.-class PrintfType t where-    spr :: String -> [UPrintf] -> t---- | The 'HPrintfType' class provides the variable argument magic for--- 'hPrintf'.  Its implementation is intentionally not visible from--- this module.-class HPrintfType t where-    hspr :: Handle -> String -> [UPrintf] -> t--{- not allowed in Haskell 2010-instance PrintfType String where-    spr fmt args = uprintf fmt (reverse args)--}--- | @since 2.01-instance (IsChar c) => PrintfType [c] where-    spr fmts args = map fromChar (uprintf fmts (reverse args))---- Note that this should really be (IO ()), but GHC's--- type system won't readily let us say that without--- bringing the GADTs. So we go conditional for these defs.---- | @since 4.7.0.0-instance (a ~ ()) => PrintfType (IO a) where-    spr fmts args =-        putStr $ map fromChar $ uprintf fmts $ reverse args---- | @since 4.7.0.0-instance (a ~ ()) => HPrintfType (IO a) where-    hspr hdl fmts args =-        hPutStr hdl (uprintf fmts (reverse args))---- | @since 2.01-instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where-    spr fmts args = \ a -> spr fmts-                             ((parseFormat a, formatArg a) : args)---- | @since 2.01-instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where-    hspr hdl fmts args = \ a -> hspr hdl fmts-                                  ((parseFormat a, formatArg a) : args)---- | Typeclass of 'printf'-formattable values. The 'formatArg' method--- takes a value and a field format descriptor and either fails due--- to a bad descriptor or produces a 'ShowS' as the result. The--- default 'parseFormat' expects no modifiers: this is the normal--- case. Minimal instance: 'formatArg'.-class PrintfArg a where-    -- | @since 4.7.0.0-    formatArg :: a -> FieldFormatter-    -- | @since 4.7.0.0-    parseFormat :: a -> ModifierParser-    parseFormat _ (c : cs) = FormatParse "" c cs-    parseFormat _ "" = errorShortFormat---- | @since 2.01-instance PrintfArg Char where-    formatArg = formatChar-    parseFormat _ cf = parseIntFormat (undefined :: Int) cf---- | @since 2.01-instance (IsChar c) => PrintfArg [c] where-    formatArg = formatString---- | @since 2.01-instance PrintfArg Int where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Int8 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Int16 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Int32 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Int64 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Word where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Word8 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Word16 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Word32 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Word64 where-    formatArg = formatInt-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Integer where-    formatArg = formatInteger-    parseFormat = parseIntFormat---- | @since 4.8.0.0-instance PrintfArg Natural where-    formatArg = formatInteger . toInteger-    parseFormat = parseIntFormat---- | @since 2.01-instance PrintfArg Float where-    formatArg = formatRealFloat---- | @since 2.01-instance PrintfArg Double where-    formatArg = formatRealFloat---- | This class, with only the one instance, is used as--- a workaround for the fact that 'String', as a concrete--- type, is not allowable as a typeclass instance. 'IsChar'--- is exported for backward-compatibility.-class IsChar c where-    -- | @since 4.7.0.0-    toChar :: c -> Char-    -- | @since 4.7.0.0-    fromChar :: Char -> c---- | @since 2.01-instance IsChar Char where-    toChar c = c-    fromChar c = c------------------------- | Whether to left-adjust or zero-pad a field. These are--- mutually exclusive, with 'LeftAdjust' taking precedence.------ @since 4.7.0.0-data FormatAdjustment = LeftAdjust | ZeroPad---- | How to handle the sign of a numeric field.  These are--- mutually exclusive, with 'SignPlus' taking precedence.------ @since 4.7.0.0-data FormatSign = SignPlus | SignSpace---- | Description of field formatting for 'formatArg'. See UNIX @printf(3)@--- for a description of how field formatting works.------ @since 4.7.0.0-data FieldFormat = FieldFormat {-  fmtWidth :: Maybe Int,       -- ^ Total width of the field.-  fmtPrecision :: Maybe Int,   -- ^ Secondary field width specifier.-  fmtAdjust :: Maybe FormatAdjustment,  -- ^ Kind of filling or padding-                                        --   to be done.-  fmtSign :: Maybe FormatSign, -- ^ Whether to insist on a-                               -- plus sign for positive-                               -- numbers.-  fmtAlternate :: Bool,        -- ^ Indicates an "alternate-                               -- format".  See @printf(3)@-                               -- for the details, which-                               -- vary by argument spec.-  fmtModifiers :: String,      -- ^ Characters that appeared-                               -- immediately to the left of-                               -- 'fmtChar' in the format-                               -- and were accepted by the-                               -- type's 'parseFormat'.-                               -- Normally the empty string.-  fmtChar :: Char              -- ^ The format character-                               -- 'printf' was invoked-                               -- with. 'formatArg' should-                               -- fail unless this character-                               -- matches the type. It is-                               -- normal to handle many-                               -- different format-                               -- characters for a single-                               -- type.-  }---- | The \"format parser\" walks over argument-type-specific--- modifier characters to find the primary format character.--- This is the type of its result.------ @since 4.7.0.0-data FormatParse = FormatParse {-  fpModifiers :: String,   -- ^ Any modifiers found.-  fpChar :: Char,          -- ^ Primary format character.-  fpRest :: String         -- ^ Rest of the format string.-  }---- Contains the "modifier letters" that can precede an--- integer type.-intModifierMap :: [(String, Integer)]-intModifierMap = [-  ("hh", toInteger (minBound :: Int8)),-  ("h", toInteger (minBound :: Int16)),-  ("l", toInteger (minBound :: Int32)),-  ("ll", toInteger (minBound :: Int64)),-  ("L", toInteger (minBound :: Int64)) ]--parseIntFormat :: a -> String -> FormatParse-parseIntFormat _ s =-  case foldr matchPrefix Nothing intModifierMap of-    Just m -> m-    Nothing ->-      case s of-        c : cs -> FormatParse "" c cs-        "" -> errorShortFormat-  where-    matchPrefix (p, _) m@(Just (FormatParse p0 _ _))-      | length p0 >= length p = m-      | otherwise = case getFormat p of-          Nothing -> m-          Just fp -> Just fp-    matchPrefix (p, _) Nothing =-      getFormat p-    getFormat p =-      stripPrefix p s >>= fp-      where-        fp (c : cs) = Just $ FormatParse p c cs-        fp "" = errorShortFormat---- | This is the type of a field formatter reified over its--- argument.------ @since 4.7.0.0-type FieldFormatter = FieldFormat -> ShowS---- | Type of a function that will parse modifier characters--- from the format string.------ @since 4.7.0.0-type ModifierParser = String -> FormatParse---- | Substitute a \'v\' format character with the given--- default format character in the 'FieldFormat'. A--- convenience for user-implemented types, which should--- support \"%v\".------ @since 4.7.0.0-vFmt :: Char -> FieldFormat -> FieldFormat-vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c}-vFmt _ ufmt = ufmt---- | Formatter for 'Char' values.------ @since 4.7.0.0-formatChar :: Char -> FieldFormatter-formatChar x ufmt =-  formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt---- | Formatter for 'String' values.------ @since 4.7.0.0-formatString :: IsChar a => [a] -> FieldFormatter-formatString x ufmt =-  case fmtChar $ vFmt 's' ufmt of-    's' -> map toChar . (adjust ufmt ("", ts) ++)-           where-             ts = map toChar $ trunc $ fmtPrecision ufmt-               where-                 trunc Nothing = x-                 trunc (Just n) = take n x-    c   -> errorBadFormat c---- Possibly apply the int modifiers to get a new--- int width for conversion.-fixupMods :: FieldFormat -> Maybe Integer -> Maybe Integer-fixupMods ufmt m =-  let mods = fmtModifiers ufmt in-  case mods of-    "" -> m-    _ -> case lookup mods intModifierMap of-      Just m0 -> Just m0-      Nothing -> perror "unknown format modifier"---- | Formatter for 'Int' values.------ @since 4.7.0.0-formatInt :: (Integral a, Bounded a) => a -> FieldFormatter-formatInt x ufmt =-  let lb = toInteger $ minBound `asTypeOf` x-      m = fixupMods ufmt (Just lb)-      ufmt' = case lb of-        0 -> vFmt 'u' ufmt-        _ -> ufmt-  in-  formatIntegral m (toInteger x) ufmt'---- | Formatter for 'Integer' values.------ @since 4.7.0.0-formatInteger :: Integer -> FieldFormatter-formatInteger x ufmt =-  let m = fixupMods ufmt Nothing in-  formatIntegral m x ufmt---- All formatting for integral types is handled--- consistently.  The only difference is between Integer and--- bounded types; this difference is handled by the 'm'--- argument containing the lower bound.-formatIntegral :: Maybe Integer -> Integer -> FieldFormatter-formatIntegral m x ufmt0 =-  let prec = fmtPrecision ufmt0 in-  case fmtChar ufmt of-    'd' -> (adjustSigned ufmt (fmti prec x) ++)-    'i' -> (adjustSigned ufmt (fmti prec x) ++)-    'x' -> (adjust ufmt (fmtu 16 (alt "0x" x) prec m x) ++)-    'X' -> (adjust ufmt (upcase $ fmtu 16 (alt "0X" x) prec m x) ++)-    'b' -> (adjust ufmt (fmtu 2 (alt "0b" x) prec m x) ++)-    'o' -> (adjust ufmt (fmtu 8 (alt "0" x) prec m x) ++)-    'u' -> (adjust ufmt (fmtu 10 Nothing prec m x) ++)-    'c' | x >= fromIntegral (ord (minBound :: Char)) &&-          x <= fromIntegral (ord (maxBound :: Char)) &&-          fmtPrecision ufmt == Nothing &&-          fmtModifiers ufmt == "" ->-            formatString [chr $ fromIntegral x] (ufmt { fmtChar = 's' })-    'c' -> perror "illegal char conversion"-    c   -> errorBadFormat c-  where-    ufmt = vFmt 'd' $ case ufmt0 of-      FieldFormat { fmtPrecision = Just _, fmtAdjust = Just ZeroPad } ->-        ufmt0 { fmtAdjust = Nothing }-      _ -> ufmt0-    alt _ 0 = Nothing-    alt p _ = case fmtAlternate ufmt of-      True -> Just p-      False -> Nothing-    upcase (s1, s2) = (s1, map toUpper s2)---- | Formatter for 'RealFloat' values.------ @since 4.7.0.0-formatRealFloat :: RealFloat a => a -> FieldFormatter-formatRealFloat x ufmt =-  let c = fmtChar $ vFmt 'g' ufmt-      prec = fmtPrecision ufmt-      alt = fmtAlternate ufmt-  in-   case c of-     'e' -> (adjustSigned ufmt (dfmt c prec alt x) ++)-     'E' -> (adjustSigned ufmt (dfmt c prec alt x) ++)-     'f' -> (adjustSigned ufmt (dfmt c prec alt x) ++)-     'F' -> (adjustSigned ufmt (dfmt c prec alt x) ++)-     'g' -> (adjustSigned ufmt (dfmt c prec alt x) ++)-     'G' -> (adjustSigned ufmt (dfmt c prec alt x) ++)-     _   -> errorBadFormat c---- This is the type carried around for arguments in--- the varargs code.-type UPrintf = (ModifierParser, FieldFormatter)---- Given a format string and a list of formatting functions--- (the actual argument value having already been baked into--- each of these functions before delivery), return the--- actual formatted text string.-uprintf :: String -> [UPrintf] -> String-uprintf s us = uprintfs s us ""---- This function does the actual work, producing a ShowS--- instead of a string, for future expansion and for--- misguided efficiency.-uprintfs :: String -> [UPrintf] -> ShowS-uprintfs ""       []       = id-uprintfs ""       (_:_)    = errorShortFormat-uprintfs ('%':'%':cs) us   = ('%' :) . uprintfs cs us-uprintfs ('%':_)  []       = errorMissingArgument-uprintfs ('%':cs) us@(_:_) = fmt cs us-uprintfs (c:cs)   us       = (c :) . uprintfs cs us---- Given a suffix of the format string starting just after--- the percent sign, and the list of remaining unprocessed--- arguments in the form described above, format the portion--- of the output described by this field description, and--- then continue with 'uprintfs'.-fmt :: String -> [UPrintf] -> ShowS-fmt cs0 us0 =-  case getSpecs False False Nothing False cs0 us0 of-    (_, _, []) -> errorMissingArgument-    (ufmt, cs, (_, u) : us) -> u ufmt . uprintfs cs us---- Given field formatting information, and a tuple--- consisting of a prefix (for example, a minus sign) that--- is supposed to go before the argument value and a string--- representing the value, return the properly padded and--- formatted result.-adjust :: FieldFormat -> (String, String) -> String-adjust ufmt (pre, str) =-  let naturalWidth = length pre + length str-      zero = case fmtAdjust ufmt of-        Just ZeroPad -> True-        _ -> False-      left = case fmtAdjust ufmt of-        Just LeftAdjust -> True-        _ -> False-      fill = case fmtWidth ufmt of-        Just width | naturalWidth < width ->-          let fillchar = if zero then '0' else ' ' in-          replicate (width - naturalWidth) fillchar-        _ -> ""-  in-   if left-   then pre ++ str ++ fill-   else if zero-        then pre ++ fill ++ str-        else fill ++ pre ++ str---- For positive numbers with an explicit sign field ("+" or--- " "), adjust accordingly.-adjustSigned :: FieldFormat -> (String, String) -> String-adjustSigned ufmt@(FieldFormat {fmtSign = Just SignPlus}) ("", str) =-  adjust ufmt ("+", str)-adjustSigned ufmt@(FieldFormat {fmtSign = Just SignSpace}) ("", str) =-  adjust ufmt (" ", str)-adjustSigned ufmt ps =-  adjust ufmt ps---- Format a signed integer in the "default" fashion.--- This will be subjected to adjust subsequently.-fmti :: Maybe Int -> Integer -> (String, String)-fmti prec i-  | i < 0 = ("-", integral_prec prec (show (-i)))-  | otherwise = ("", integral_prec prec (show i))---- Format an unsigned integer in the "default" fashion.--- This will be subjected to adjust subsequently.  The 'b'--- argument is the base, the 'pre' argument is the prefix,--- and the '(Just m)' argument is the implicit lower-bound--- size of the operand for conversion from signed to--- unsigned. Thus, this function will refuse to convert an--- unbounded negative integer to an unsigned string.-fmtu :: Integer -> Maybe String -> Maybe Int -> Maybe Integer -> Integer-     -> (String, String)-fmtu b (Just pre) prec m i =-  let ("", s) = fmtu b Nothing prec m i in-  case pre of-    "0" -> case s of-      '0' : _ -> ("", s)-      _ -> (pre, s)-    _ -> (pre, s)-fmtu b Nothing prec0 m0 i0 =-  case fmtu' prec0 m0 i0 of-    Just s -> ("", s)-    Nothing -> errorBadArgument-  where-    fmtu' :: Maybe Int -> Maybe Integer -> Integer -> Maybe String-    fmtu' prec (Just m) i | i < 0 =-      fmtu' prec Nothing (-2 * m + i)-    fmtu' (Just prec) _ i | i >= 0 =-      fmap (integral_prec (Just prec)) $ fmtu' Nothing Nothing i-    fmtu' Nothing _ i | i >= 0 =-      Just $ showIntAtBase b intToDigit i ""-    fmtu' _ _ _ = Nothing----- This is used by 'fmtu' and 'fmti' to zero-pad an--- int-string to a required precision.-integral_prec :: Maybe Int -> String -> String-integral_prec Nothing integral = integral-integral_prec (Just 0) "0" = ""-integral_prec (Just prec) integral =-  replicate (prec - length integral) '0' ++ integral--stoi :: String -> (Int, String)-stoi cs =-  let (as, cs') = span isDigit cs in-  case as of-    "" -> (0, cs')-    _ -> (read as, cs')---- Figure out the FormatAdjustment, given:---   width, precision, left-adjust, zero-fill-adjustment :: Maybe Int -> Maybe a -> Bool -> Bool-           -> Maybe FormatAdjustment-adjustment w p l z =-  case w of-    Just n | n < 0 -> adjl p True z-    _ -> adjl p l z-  where-    adjl _ True _ = Just LeftAdjust-    adjl _ False True = Just ZeroPad-    adjl _ _ _ = Nothing---- Parse the various format controls to get a format specification.-getSpecs :: Bool -> Bool -> Maybe FormatSign -> Bool -> String -> [UPrintf]-         -> (FieldFormat, String, [UPrintf])-getSpecs _ z s a ('-' : cs0) us = getSpecs True z s a cs0 us-getSpecs l z _ a ('+' : cs0) us = getSpecs l z (Just SignPlus) a cs0 us-getSpecs l z s a (' ' : cs0) us =-  getSpecs l z ss a cs0 us-  where-    ss = case s of-      Just SignPlus -> Just SignPlus-      _ -> Just SignSpace-getSpecs l _ s a ('0' : cs0) us = getSpecs l True s a cs0 us-getSpecs l z s _ ('#' : cs0) us = getSpecs l z s True cs0 us-getSpecs l z s a ('*' : cs0) us =-  let (us', n) = getStar us-      ((p, cs''), us'') = case cs0 of-        '.':'*':r ->-          let (us''', p') = getStar us' in ((Just p', r), us''')-        '.':r ->-          let (p', r') = stoi r in ((Just p', r'), us')-        _ ->-          ((Nothing, cs0), us')-      FormatParse ms c cs =-        case us'' of-          (ufmt, _) : _ -> ufmt cs''-          [] -> errorMissingArgument-  in-   (FieldFormat {-       fmtWidth = Just (abs n),-       fmtPrecision = p,-       fmtAdjust = adjustment (Just n) p l z,-       fmtSign = s,-       fmtAlternate = a,-       fmtModifiers = ms,-       fmtChar = c}, cs, us'')-getSpecs l z s a ('.' : cs0) us =-  let ((p, cs'), us') = case cs0 of-        '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')-        _ ->        (stoi cs0, us)-      FormatParse ms c cs =-        case us' of-          (ufmt, _) : _ -> ufmt cs'-          [] -> errorMissingArgument-  in-   (FieldFormat {-       fmtWidth = Nothing,-       fmtPrecision = Just p,-       fmtAdjust = adjustment Nothing (Just p) l z,-       fmtSign = s,-       fmtAlternate = a,-       fmtModifiers = ms,-       fmtChar = c}, cs, us')-getSpecs l z s a cs0@(c0 : _) us | isDigit c0 =-  let (n, cs') = stoi cs0-      ((p, cs''), us') = case cs' of-        '.' : '*' : r ->-          let (us'', p') = getStar us in ((Just p', r), us'')-        '.' : r ->-          let (p', r') = stoi r in ((Just p', r'), us)-        _ ->-          ((Nothing, cs'), us)-      FormatParse ms c cs =-        case us' of-          (ufmt, _) : _ -> ufmt cs''-          [] -> errorMissingArgument-  in-   (FieldFormat {-       fmtWidth = Just (abs n),-       fmtPrecision = p,-       fmtAdjust = adjustment (Just n) p l z,-       fmtSign = s,-       fmtAlternate = a,-       fmtModifiers = ms,-       fmtChar = c}, cs, us')-getSpecs l z s a cs0@(_ : _) us =-  let FormatParse ms c cs =-        case us of-          (ufmt, _) : _ -> ufmt cs0-          [] -> errorMissingArgument-  in-   (FieldFormat {-       fmtWidth = Nothing,-       fmtPrecision = Nothing,-       fmtAdjust = adjustment Nothing Nothing l z,-       fmtSign = s,-       fmtAlternate = a,-       fmtModifiers = ms,-       fmtChar = c}, cs, us)-getSpecs _ _ _ _ ""       _  =-  errorShortFormat---- Process a star argument in a format specification.-getStar :: [UPrintf] -> ([UPrintf], Int)-getStar us =-  let ufmt = FieldFormat {-        fmtWidth = Nothing,-        fmtPrecision = Nothing,-        fmtAdjust = Nothing,-        fmtSign = Nothing,-        fmtAlternate = False,-        fmtModifiers = "",-        fmtChar = 'd' } in-  case us of-    [] -> errorMissingArgument-    (_, nu) : us' -> (us', read (nu ufmt ""))---- Format a RealFloat value.-dfmt :: (RealFloat a) => Char -> Maybe Int -> Bool -> a -> (String, String)-dfmt c p a d =-  let caseConvert = if isUpper c then map toUpper else id-      showFunction = case toLower c of-        'e' -> showEFloat-        'f' -> if a then showFFloatAlt else showFFloat-        'g' -> if a then showGFloatAlt else showGFloat-        _   -> perror "internal error: impossible dfmt"-      result = caseConvert $ showFunction p d ""-  in-   case result of-     '-' : cs -> ("-", cs)-     cs       -> ("" , cs)----- | Raises an 'error' with a printf-specific prefix on the--- message string.------ @since 4.7.0.0-perror :: String -> a-perror s = errorWithoutStackTrace $ "printf: " ++ s---- | Calls 'perror' to indicate an unknown format letter for--- a given type.------ @since 4.7.0.0-errorBadFormat :: Char -> a-errorBadFormat c = perror $ "bad formatting char " ++ show c--errorShortFormat, errorMissingArgument, errorBadArgument :: a--- | Calls 'perror' to indicate that the format string ended--- early.------ @since 4.7.0.0-errorShortFormat = perror "formatting string ended prematurely"--- | Calls 'perror' to indicate that there is a missing--- argument in the argument list.------ @since 4.7.0.0-errorMissingArgument = perror "argument list ended prematurely"--- | Calls 'perror' to indicate that there is a type--- error or similar in the given argument.------ @since 4.7.0.0-errorBadArgument = perror "bad argument"
− Text/Read.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Text.Read--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (uses Text.ParserCombinators.ReadP)------ Converting strings to values.------ The "Text.Read" library is the canonical library to import for--- 'Read'-class facilities.  For GHC only, it offers an extended and much--- improved 'Read' class, which constitutes a proposed alternative to the--- Haskell 2010 'Read'.  In particular, writing parsers is easier, and--- the parsers are much more efficient.-----------------------------------------------------------------------------------module Text.Read (-   -- * The 'Read' class-   Read(..),-   ReadS,--   -- * Haskell 2010 functions-   reads,-   read,-   readParen,-   lex,--   -- * New parsing functions-   module Text.ParserCombinators.ReadPrec,-   L.Lexeme(..),-   lexP,-   parens,-   readListDefault,-   readListPrecDefault,-   readEither,-   readMaybe-- ) where--import GHC.Base-import GHC.Read-import Data.Either-import Text.ParserCombinators.ReadP as P-import Text.ParserCombinators.ReadPrec-import qualified Text.Read.Lex as L---- $setup--- >>> import Prelude----------------------------------------------------------------------------- utility functions---- | equivalent to 'readsPrec' with a precedence of 0.-reads :: Read a => ReadS a-reads = readsPrec minPrec---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.--- A 'Left' value indicates a parse error.------ >>> readEither "123" :: Either String Int--- Right 123------ >>> readEither "hello" :: Either String Int--- Left "Prelude.read: no parse"------ @since 4.6.0.0-readEither :: Read a => String -> Either String a-readEither s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Right x-    []  -> Left "Prelude.read: no parse"-    _   -> Left "Prelude.read: ambiguous parse"- where-  read' =-    do x <- readPrec-       lift P.skipSpaces-       return x---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.------ >>> readMaybe "123" :: Maybe Int--- Just 123------ >>> readMaybe "hello" :: Maybe Int--- Nothing------ @since 4.6.0.0-readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of-                Left _  -> Nothing-                Right a -> Just a---- | The 'read' function reads input from a string, which must be--- completely consumed by the input process. 'read' fails with an 'error' if the--- parse is unsuccessful, and it is therefore discouraged from being used in--- real applications. Use 'readMaybe' or 'readEither' for safe alternatives.------ >>> read "123" :: Int--- 123------ >>> read "hello" :: Int--- *** Exception: Prelude.read: no parse-read :: Read a => String -> a-read s = either errorWithoutStackTrace id (readEither s)
− Text/Read/Lex.hs 
@@ -1,593 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Text.Read.Lex--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  non-portable (uses Text.ParserCombinators.ReadP)------ The cut-down Haskell lexer, used by Text.Read-----------------------------------------------------------------------------------module Text.Read.Lex-  -- lexing types-  ( Lexeme(..), Number--  , numberToInteger, numberToFixed, numberToRational, numberToRangedRational--  -- lexer-  , lex, expect-  , hsLex-  , lexChar--  , readBinP-  , readIntP-  , readOctP-  , readDecP-  , readHexP--  , isSymbolChar-  )- where--import Text.ParserCombinators.ReadP--import GHC.Base-import GHC.Char-import GHC.Num( Num(..), Integer )-import GHC.Show( Show(..) )-import GHC.Unicode-  ( GeneralCategory(..), generalCategory, isSpace, isAlpha, isAlphaNum )-import GHC.Real( Rational, (%), fromIntegral, Integral,-                 toInteger, (^), quot, even )-import GHC.List-import GHC.Enum( minBound, maxBound )-import Data.Maybe---- local copy to break import-cycle--- | @'guard' b@ is @'return' ()@ if @b@ is 'True',--- and 'mzero' if @b@ is 'False'.-guard           :: (MonadPlus m) => Bool -> m ()-guard True      =  return ()-guard False     =  mzero---- -------------------------------------------------------------------------------- Lexing types---- ^ Haskell lexemes.-data Lexeme-  = Char   Char         -- ^ Character literal-  | String String       -- ^ String literal, with escapes interpreted-  | Punc   String       -- ^ Punctuation or reserved symbol, e.g. @(@, @::@-  | Ident  String       -- ^ Haskell identifier, e.g. @foo@, @Baz@-  | Symbol String       -- ^ Haskell symbol, e.g. @>>@, @:%@-  | Number Number       -- ^ @since 4.6.0.0-  | EOF- deriving ( Eq   -- ^ @since 2.01-          , Show -- ^ @since 2.01-          )---- | @since 4.6.0.0-data Number = MkNumber Int              -- Base-                       Digits           -- Integral part-            | MkDecimal Digits          -- Integral part-                        (Maybe Digits)  -- Fractional part-                        (Maybe Integer) -- Exponent- deriving ( Eq   -- ^ @since 4.6.0.0-          , Show -- ^ @since 4.6.0.0-          )---- | @since 4.5.1.0-numberToInteger :: Number -> Maybe Integer-numberToInteger (MkNumber base iPart) = Just (val (fromIntegral base) iPart)-numberToInteger (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart)-numberToInteger _ = Nothing---- | @since 4.7.0.0-numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)-numberToFixed _ (MkNumber base iPart) = Just (val (fromIntegral base) iPart, 0)-numberToFixed _ (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart, 0)-numberToFixed p (MkDecimal iPart (Just fPart) Nothing)-    = let i = val 10 iPart-          f = val 10 (integerTake p (fPart ++ repeat 0))-          -- Sigh, we really want genericTake, but that's above us in-          -- the hierarchy, so we define our own version here (actually-          -- specialised to Integer)-          integerTake             :: Integer -> [a] -> [a]-          integerTake n _ | n <= 0 = []-          integerTake _ []        =  []-          integerTake n (x:xs)    =  x : integerTake (n-1) xs-      in Just (i, f)-numberToFixed _ _ = Nothing---- This takes a floatRange, and if the Rational would be outside of--- the floatRange then it may return Nothing. Not that it will not--- /necessarily/ return Nothing, but it is good enough to fix the--- space problems in #5688--- Ways this is conservative:--- * the floatRange is in base 2, but we pretend it is in base 10--- * we pad the floateRange a bit, just in case it is very small---   and we would otherwise hit an edge case--- * We only worry about numbers that have an exponent. If they don't---   have an exponent then the Rational won't be much larger than the---   Number, so there is no problem--- | @since 4.5.1.0-numberToRangedRational :: (Int, Int) -> Number-                       -> Maybe Rational -- Nothing = Inf-numberToRangedRational (neg, pos) n@(MkDecimal iPart mFPart (Just exp))-    -- if exp is out of integer bounds,-    -- then the number is definitely out of range-    | exp > fromIntegral (maxBound :: Int) ||-      exp < fromIntegral (minBound :: Int)-    = Nothing-    | otherwise-    = let mFirstDigit = case dropWhile (0 ==) iPart of-                        iPart'@(_ : _) -> Just (length iPart')-                        [] -> case mFPart of-                              Nothing -> Nothing-                              Just fPart ->-                                  case span (0 ==) fPart of-                                  (_, []) -> Nothing-                                  (zeroes, _) ->-                                      Just (negate (length zeroes))-      in case mFirstDigit of-         Nothing -> Just 0-         Just firstDigit ->-             let firstDigit' = firstDigit + fromInteger exp-             in if firstDigit' > (pos + 3)-                then Nothing-                else if firstDigit' < (neg - 3)-                then Just 0-                else Just (numberToRational n)-numberToRangedRational _ n = Just (numberToRational n)---- | @since 4.6.0.0-numberToRational :: Number -> Rational-numberToRational (MkNumber base iPart) = val (fromIntegral base) iPart % 1-numberToRational (MkDecimal iPart mFPart mExp)- = let i = val 10 iPart-   in case (mFPart, mExp) of-      (Nothing, Nothing)     -> i % 1-      (Nothing, Just exp)-       | exp >= 0            -> (i * (10 ^ exp)) % 1-       | otherwise           -> i % (10 ^ (- exp))-      (Just fPart, Nothing)  -> fracExp 0   i fPart-      (Just fPart, Just exp) -> fracExp exp i fPart-      -- fracExp is a bit more efficient in calculating the Rational.-      -- Instead of calculating the fractional part alone, then-      -- adding the integral part and finally multiplying with-      -- 10 ^ exp if an exponent was given, do it all at once.---- -------------------------------------------------------------------------------- Lexing--lex :: ReadP Lexeme-lex = skipSpaces >> lexToken---- | @since 4.7.0.0-expect :: Lexeme -> ReadP ()-expect lexeme = do { skipSpaces-                   ; thing <- lexToken-                   ; if thing == lexeme then return () else pfail }--hsLex :: ReadP String--- ^ Haskell lexer: returns the lexed string, rather than the lexeme-hsLex = do skipSpaces-           (s,_) <- gather lexToken-           return s--lexToken :: ReadP Lexeme-lexToken = lexEOF     +++-           lexLitChar +++-           lexString  +++-           lexPunc    +++-           lexSymbol  +++-           lexId      +++-           lexNumber----- ------------------------------------------------------------------------- End of file-lexEOF :: ReadP Lexeme-lexEOF = do s <- look-            guard (null s)-            return EOF---- ------------------------------------------------------------------------------ Single character lexemes--lexPunc :: ReadP Lexeme-lexPunc =-  do c <- satisfy isPuncChar-     return (Punc [c])---- | The @special@ character class as defined in the Haskell Report.-isPuncChar :: Char -> Bool-isPuncChar c = c `elem` ",;()[]{}`"---- ------------------------------------------------------------------------- Symbols--lexSymbol :: ReadP Lexeme-lexSymbol =-  do s <- munch1 isSymbolChar-     if s `elem` reserved_ops then-        return (Punc s)         -- Reserved-ops count as punctuation-      else-        return (Symbol s)-  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--lexId :: ReadP Lexeme-lexId = do c <- satisfy isIdsChar-           s <- munch isIdfChar-           return (Ident (c:s))-  where-          -- Identifiers can start with a '_'-    isIdsChar c = isAlpha c || c == '_'-    isIdfChar c = isAlphaNum c || c `elem` "_'"---- ------------------------------------------------------------------------------ Lexing character literals--lexLitChar :: ReadP Lexeme-lexLitChar =-  do _ <- char '\''-     (c,esc) <- lexCharE-     guard (esc || c /= '\'')   -- Eliminate '' possibility-     _ <- char '\''-     return (Char c)--lexChar :: ReadP Char-lexChar = do { (c,_) <- lexCharE; consumeEmpties; return c }-    where-    -- Consumes the string "\&" repeatedly and greedily (will only produce one match)-    consumeEmpties :: ReadP ()-    consumeEmpties = do-        rest <- look-        case rest of-            ('\\':'&':_) -> string "\\&" >> consumeEmpties-            _ -> return ()---lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?-lexCharE =-  do c1 <- get-     if c1 == '\\'-       then do c2 <- lexEsc; return (c2, True)-       else return (c1, False)- where-  lexEsc =-    lexEscChar-      +++ lexNumeric-        +++ lexCntrlChar-          +++ lexAscii--  lexEscChar =-    do c <- get-       case c of-         'a'  -> return '\a'-         'b'  -> return '\b'-         'f'  -> return '\f'-         'n'  -> return '\n'-         'r'  -> return '\r'-         't'  -> return '\t'-         'v'  -> return '\v'-         '\\' -> return '\\'-         '\"' -> return '\"'-         '\'' -> return '\''-         _    -> pfail--  lexNumeric =-    do base <- lexBaseChar <++ return 10-       n    <- lexInteger base-       guard (n <= toInteger (ord maxBound))-       return (chr (fromInteger n))--  lexCntrlChar =-    do _ <- char '^'-       c <- get-       case c of-         '@'  -> return '\^@'-         'A'  -> return '\^A'-         'B'  -> return '\^B'-         'C'  -> return '\^C'-         'D'  -> return '\^D'-         'E'  -> return '\^E'-         'F'  -> return '\^F'-         'G'  -> return '\^G'-         'H'  -> return '\^H'-         'I'  -> return '\^I'-         'J'  -> return '\^J'-         'K'  -> return '\^K'-         'L'  -> return '\^L'-         'M'  -> return '\^M'-         'N'  -> return '\^N'-         'O'  -> return '\^O'-         'P'  -> return '\^P'-         'Q'  -> return '\^Q'-         'R'  -> return '\^R'-         'S'  -> return '\^S'-         'T'  -> return '\^T'-         'U'  -> return '\^U'-         'V'  -> return '\^V'-         'W'  -> return '\^W'-         'X'  -> return '\^X'-         'Y'  -> return '\^Y'-         'Z'  -> return '\^Z'-         '['  -> return '\^['-         '\\' -> return '\^\'-         ']'  -> return '\^]'-         '^'  -> return '\^^'-         '_'  -> return '\^_'-         _    -> pfail--  lexAscii =-     choice-         [ (string "SOH" >> return '\SOH') <++-           (string "SO"  >> return '\SO')-                -- \SO and \SOH need maximal-munch treatment-                -- See the Haskell report Sect 2.6--         , string "NUL" >> return '\NUL'-         , string "STX" >> return '\STX'-         , string "ETX" >> return '\ETX'-         , string "EOT" >> return '\EOT'-         , string "ENQ" >> return '\ENQ'-         , string "ACK" >> return '\ACK'-         , string "BEL" >> return '\BEL'-         , string "BS"  >> return '\BS'-         , string "HT"  >> return '\HT'-         , string "LF"  >> return '\LF'-         , string "VT"  >> return '\VT'-         , string "FF"  >> return '\FF'-         , string "CR"  >> return '\CR'-         , string "SI"  >> return '\SI'-         , string "DLE" >> return '\DLE'-         , string "DC1" >> return '\DC1'-         , string "DC2" >> return '\DC2'-         , string "DC3" >> return '\DC3'-         , string "DC4" >> return '\DC4'-         , string "NAK" >> return '\NAK'-         , string "SYN" >> return '\SYN'-         , string "ETB" >> return '\ETB'-         , string "CAN" >> return '\CAN'-         , string "EM"  >> return '\EM'-         , string "SUB" >> return '\SUB'-         , string "ESC" >> return '\ESC'-         , string "FS"  >> return '\FS'-         , string "GS"  >> return '\GS'-         , string "RS"  >> return '\RS'-         , string "US"  >> return '\US'-         , string "SP"  >> return '\SP'-         , string "DEL" >> return '\DEL'-         ]----- ------------------------------------------------------------------------------ string literal--lexString :: ReadP Lexeme-lexString =-  do _ <- char '"'-     body id- where-  body f =-    do (c,esc) <- lexStrItem-       if c /= '"' || esc-         then body (f.(c:))-         else let s = f "" in-              return (String s)--  lexStrItem = (lexEmpty >> lexStrItem)-               +++ lexCharE--  lexEmpty =-    do _ <- char '\\'-       c <- get-       case c of-         '&'           -> return ()-         _ | isSpace c -> do skipSpaces; _ <- char '\\'; return ()-         _             -> pfail---- ------------------------------------------------------------------------------  Lexing numbers--type Base   = Int-type Digits = [Int]--lexNumber :: ReadP Lexeme-lexNumber-  = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc-                        -- If that fails, try for a decimal number-    lexDecNumber        -- Start with ordinary digits--lexHexOct :: ReadP Lexeme-lexHexOct-  = do  _ <- char '0'-        base <- lexBaseChar-        digits <- lexDigits base-        return (Number (MkNumber base digits))--lexBaseChar :: ReadP Int--- Lex a single character indicating the base; fail if not there-lexBaseChar = do-  c <- get-  case c of-    'o' -> return 8-    'O' -> return 8-    'x' -> return 16-    'X' -> return 16-    _   -> pfail--lexDecNumber :: ReadP Lexeme-lexDecNumber =-  do xs    <- lexDigits 10-     mFrac <- lexFrac <++ return Nothing-     mExp  <- lexExp  <++ return Nothing-     return (Number (MkDecimal xs mFrac mExp))--lexFrac :: ReadP (Maybe Digits)--- Read the fractional part; fail if it doesn't--- start ".d" where d is a digit-lexFrac = do _ <- char '.'-             fraction <- lexDigits 10-             return (Just fraction)--lexExp :: ReadP (Maybe Integer)-lexExp = do _ <- char 'e' +++ char 'E'-            exp <- signedExp +++ lexInteger 10-            return (Just exp)- where-   signedExp-     = do c <- char '-' +++ char '+'-          n <- lexInteger 10-          return (if c == '-' then -n else n)--lexDigits :: Int -> ReadP Digits--- Lex a non-empty sequence of digits in specified base-lexDigits base =-  do s  <- look-     xs <- scan s id-     guard (not (null xs))-     return xs- where-  scan (c:cs) f = case valDig base c of-                    Just n  -> do _ <- get; scan cs (f.(n:))-                    Nothing -> return (f [])-  scan []     f = return (f [])--lexInteger :: Base -> ReadP Integer-lexInteger base =-  do xs <- lexDigits base-     return (val (fromIntegral base) xs)--val :: Num a => a -> Digits -> a-val = valSimple-{-# RULES-"val/Integer" val = valInteger-  #-}-{-# INLINE [1] val #-}---- The following algorithm is only linear for types whose Num operations--- are in constant time.-valSimple :: (Num a, Integral d) => a -> [d] -> a-valSimple base = go 0-  where-    go r [] = r-    go r (d : ds) = r' `seq` go r' ds-      where-        r' = r * base + fromIntegral d-{-# INLINE valSimple #-}---- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b--- digits are combined into a single radix b^2 digit. This process is--- repeated until we are left with a single digit. This algorithm--- performs well only on large inputs, so we use the simple algorithm--- for smaller inputs.-valInteger :: Integer -> Digits -> Integer-valInteger b0 ds0 = go b0 (length ds0) $ map fromIntegral ds0-  where-    go _ _ []  = 0-    go _ _ [d] = d-    go b l ds-        | l > 40 = b' `seq` go b' l' (combine b ds')-        | otherwise = valSimple b ds-      where-        -- ensure that we have an even number of digits-        -- before we call combine:-        ds' = if even l then ds else 0 : ds-        b' = b * b-        l' = (l + 1) `quot` 2-    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)-      where-        d = d1 * b + d2-    combine _ []  = []-    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--- part. Leaving the calculation of the power of 10 until the end,--- when we know the effective exponent, saves multiplications.--- More importantly, this way we need at most one gcd instead of three.------ frac was never used with anything but Integer and base 10, so--- those are hardcoded now (trivial to change if necessary).-fracExp :: Integer -> Integer -> Digits -> Rational-fracExp exp mant []-  | exp < 0     = mant % (10 ^ (-exp))-  | otherwise   = fromInteger (mant * 10 ^ exp)-fracExp exp mant (d:ds) = exp' `seq` mant' `seq` fracExp exp' mant' ds-  where-    exp'  = exp - 1-    mant' = mant * 10 + fromIntegral d--valDig :: (Eq a, Num a) => a -> Char -> Maybe Int-valDig 2 c-  | '0' <= c && c <= '1' = Just (ord c - ord '0')-  | otherwise            = Nothing--valDig 8 c-  | '0' <= c && c <= '7' = Just (ord c - ord '0')-  | otherwise            = Nothing--valDig 10 c = valDecDig c--valDig 16 c-  | '0' <= c && c <= '9' = Just (ord c - ord '0')-  | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)-  | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)-  | otherwise            = Nothing--valDig _ _ = errorWithoutStackTrace "valDig: Bad base"--valDecDig :: Char -> Maybe Int-valDecDig c-  | '0' <= c && c <= '9' = Just (ord c - ord '0')-  | otherwise            = Nothing---- ------------------------------------------------------------------------- other numeric lexing functions--readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a-readIntP base isDigit valDigit =-  do s <- munch1 isDigit-     return (val base (map valDigit s))-{-# SPECIALISE readIntP-        :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadP Integer #-}--readIntP' :: (Eq a, Num a) => a -> ReadP a-readIntP' base = readIntP base isDigit valDigit- where-  isDigit  c = maybe False (const True) (valDig base c)-  valDigit c = maybe 0     id           (valDig base c)-{-# SPECIALISE readIntP' :: Integer -> ReadP Integer #-}--readBinP, readOctP, readDecP, readHexP :: (Eq a, Num a) => ReadP a-readBinP = readIntP' 2-readOctP = readIntP' 8-readDecP = readIntP' 10-readHexP = readIntP' 16-{-# SPECIALISE readBinP :: ReadP Integer #-}-{-# SPECIALISE readOctP :: ReadP Integer #-}-{-# SPECIALISE readDecP :: ReadP Integer #-}-{-# SPECIALISE readHexP :: ReadP Integer #-}
− Text/Show.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE NoImplicitPrelude #-}---------------------------------------------------------------------------------- |--- Module      :  Text.Show--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Converting values to readable strings:--- the 'Show' class and associated functions.-----------------------------------------------------------------------------------module Text.Show (-   ShowS,-   Show(showsPrec, show, showList),-   shows,-   showChar,-   showString,-   showParen,-   showListWith,- ) where--import GHC.Show---- | Show a list (using square brackets and commas), given a function--- for showing elements.-showListWith :: (a -> ShowS) -> [a] -> ShowS-showListWith = showList__
− Text/Show/Functions.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE Safe #-}--- This module deliberately declares orphan instances:-{-# OPTIONS_GHC -Wno-orphans #-}---------------------------------------------------------------------------------- |--- Module      :  Text.Show.Functions--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ Optional instance of 'Text.Show.Show' for functions:------ > instance Show (a -> b) where--- >    showsPrec _ _ = showString "<function>"-----------------------------------------------------------------------------------module Text.Show.Functions () where---- | @since 2.01-instance Show (a -> b) where-        showsPrec _ _ = showString "<function>"-
− Type/Reflection.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PatternSynonyms #-}---------------------------------------------------------------------------------- |--- Module      :  Type.Reflection--- Copyright   :  (c) The University of Glasgow, CWI 2001--2017--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (requires GADTs and compiler support)------ This provides a type-indexed type representation mechanism, similar to that--- described by,------ * Simon Peyton-Jones, Stephanie Weirich, Richard Eisenberg,--- Dimitrios Vytiniotis. "A reflection on types."--- /Proc. Philip Wadler's 60th birthday Festschrift/, Edinburgh (April 2016).--- ([PDF](https://www.microsoft.com/en-us/research/wp-content/uploads/2016/08/dynamic.pdf))------ The interface provides 'I.TypeRep', a type representation which can--- be safely decomposed and composed. See "Data.Dynamic" for an example of this.------ @since 4.10.0.0----------------------------------------------------------------------------------module Type.Reflection-    ( -- * The Typeable class-      I.Typeable-    , I.typeRep-    , I.withTypeable--      -- * Propositional equality-    , (:~:)(Refl)-    , (:~~:)(HRefl)--      -- * Type representations-      -- ** Type-Indexed-    , I.TypeRep-    , I.typeOf-    , pattern I.App, pattern I.Con, pattern I.Con', pattern I.Fun-    , I.typeRepTyCon-    , I.rnfTypeRep-    , I.eqTypeRep-    , I.typeRepKind-    , I.splitApps--      -- ** Quantified-      ---      -- "Data.Typeable" exports a variant of this interface (named differently-      -- for backwards compatibility).-    , I.SomeTypeRep(..)-    , I.someTypeRep-    , I.someTypeRepTyCon-    , I.rnfSomeTypeRep--      -- * Type constructors-    , I.TyCon           -- abstract, instance of: Eq, Show, Typeable-                        -- For now don't export Module, to avoid name clashes-    , I.tyConPackage-    , I.tyConModule-    , I.tyConName-    , I.rnfTyCon--      -- * Module names-    , I.Module-    , I.moduleName, I.modulePackage, I.rnfModule-    ) where--import qualified Data.Typeable.Internal as I-import Data.Type.Equality
− Type/Reflection/Unsafe.hs 
@@ -1,34 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Type.Reflection.Unsafe--- Copyright   :  (c) The University of Glasgow, CWI 2001--2015--- License     :  BSD-style (see the file libraries/base/LICENSE)------ The representations of the types 'TyCon' and 'TypeRep', and the function--- 'mkTyCon' which is used by derived instances of 'Typeable' to construct--- 'TyCon's.------ Be warned, these functions can be used to construct ill-kinded--- type representations.----------------------------------------------------------------------------------{-# LANGUAGE PolyKinds, DataKinds, ScopedTypeVariables #-}--module Type.Reflection.Unsafe (-      -- * Type representations-      TypeRep, mkTrApp, mkTyCon, typeRepFingerprint, someTypeRepFingerprint-      -- * Kind representations-    , KindRep(..), TypeLitSort(..)-      -- * Type constructors-    , TyCon, mkTrCon, tyConKindRep, tyConKindArgs, tyConFingerprint-  ) where--import Data.Typeable.Internal hiding (mkTrApp)-import qualified Data.Typeable.Internal as TI---- | Construct a representation for a type application.-mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).-           TypeRep (a :: k1 -> k2)-        -> TypeRep (b :: k1)-        -> TypeRep (a b)-mkTrApp = TI.mkTrAppChecked
− Unsafe/Coerce.hs 
@@ -1,301 +0,0 @@--- We don't to strictness analysis on this file to avoid turning loopy unsafe--- equality terms below to actual loops. Details in (U5) of--- Note [Implementing unsafeCoerce]-{-# OPTIONS_GHC -fno-strictness #-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE Unsafe #-}--module Unsafe.Coerce-  ( unsafeCoerce, unsafeCoerceUnlifted, unsafeCoerceAddr-  , unsafeEqualityProof-  , UnsafeEquality (..)-  , unsafeCoerce#-  ) where--import GHC.Arr (amap) -- For amap/unsafeCoerce rule-import GHC.Base--import GHC.Types--{- Note [Implementing unsafeCoerce]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The implementation of unsafeCoerce is surprisingly subtle.-This Note describes the moving parts.  You will find more-background in MR !1869 and ticket #16893.--The key challenge is this.  Suppose we have-   case sameTypeRep t1 t2 of-      False -> blah2-      True  -> ...(case (x |> UnsafeCo @t1 @t2) of { K -> blah })...--The programmer thinks that the unsafeCoerce from 't1' to 't2' is safe,-because it is justified by a runtime test (sameTypeRep t1 t2).-It used to compile to a cast, with a magical 'UnsafeCo' coercion.--But alas, nothing then stops GHC floating that call to unsafeCoerce-outwards so we get-   case (x |> UnsafeCo @t1 @t2) of-     K -> case sameTypeRep t1 t2 of-             False -> blah2-             True  -> ...blah...--and this is utterly wrong, because the unsafeCoerce is being performed-before the dynamic test. This is exactly the setup in #16893.--The solution is this:--* In the library Unsafe.Coerce we define:--     unsafeEqualityProof :: forall k (a :: k) (b :: k).-                            UnsafeEquality a b--* It uses a GADT, Unsafe.Coerce.UnsafeEquality, that is exactly like :~:--    data UnsafeEquality (a :: k) (b :: k) where-      UnsafeRefl :: UnsafeEquality a a--* We can now define Unsafe.Coerce.unsafeCoerce very simply:--   unsafeCoerce :: forall (a :: Type) (b :: Type) . a -> b-   unsafeCoerce x = case unsafeEqualityProof @a @b of-                      UnsafeRefl -> x--  There is nothing special about unsafeCoerce; it is an-  ordinary library definition, and can be freely inlined.--Now our bad case can't happen.  We'll have-     case unsafeEqualityProof @t1 @t2 of-        UnsafeRefl (co :: t1 ~ t2) -> ....(x |> co)....--and the (x |> co) mentions the evidence 'co', which prevents it-floating.--But what stops the whole (case unsafeEqualityProof of ...) from-floating?  Answer: we never float a case on a redex that can fail-outside a conditional.  See Primop.hs,-Note [Transformations affected by can_fail and has_side_effects].-And unsafeEqualityProof (being opaque) is definitely treated as-can-fail.--While unsafeCoerce is a perfectly ordinary function that needs no-special treatment, Unsafe.Coerce.unsafeEqualityProof is magical, in-several ways--(U1) unsafeEqualityProof is /never/ inlined.--(U2) In CoreToStg.Prep, we transform-       case unsafeEqualityProof of UnsafeRefl g -> blah-      ==>-       blah[unsafe-co/g]--     This eliminates the overhead of evaluating the unsafe-     equality proof.--     Any /other/ occurrence of unsafeEqualityProof is left alone.-     For example you could write-         f :: UnsafeEquality a b -> blah-         f eq_proof = case eq_proof of UnsafeRefl -> ...-    (Nothing special about that.)  In a call, you might write-         f unsafeEqualityProof--    and we'll generate code simply by passing the top-level-    unsafeEqualityProof to f.  As (U5) says, it is implemented as-    UnsafeRefl so all is good.--    NB: Don't discard the case if the case-binder is used-           case unsafeEqualityProof of wild_xx { UnsafeRefl ->-           ...wild_xx...-        That rarely happens, but see #18227.--(U3) In GHC.CoreToStg.Prep.cpeRhsE, if we see-       let x = case unsafeEqualityProof ... of-                 UnsafeRefl -> K e-       in ...--     there is a danger that we'll go to-        let x = case unsafeEqualityProof ... of-                  UnsafeRefl -> let a = e in K a-        in ...--     and produce a thunk even after discarding the unsafeEqualityProof.-     So instead we float out the case to give-        case unsafeEqualityProof ... of { UnsafeRefl ->-        let a = e-            x = K a-        in ...  }-     Floating the case is OK here, even though it broadens the-     scope, because we are done with simplification.--(U4) Ditto GHC.Core.Unfold.inlineBoringOk we want to treat-     the RHS of unsafeCoerce as very small; see-     Note [Inline unsafeCoerce] in that module.--(U5) The definition of unsafeEqualityProof in Unsafe.Coerce-     looks very strange:-        unsafeEqualityProof = case unsafeEqualityProof @a @b of-                                 UnsafeRefl -> UnsafeRefl--     It looks recursive!  But the above-mentioned CoreToStg-     transform will change it to-        unsafeEqualityProof = UnsafeRefl-     And that is exactly the code we want!  For example, if we say-        f unsafeEqualityProof-     we want to pass an UnsafeRefl constructor to f.--     We turn off strictness analysis in this module, otherwise-     the strictness analyser will mark unsafeEqualityProof as-     bottom, which is utterly wrong.--(U6) The UnsafeEquality data type is also special in one way.-     Consider this piece of Core-        case unsafeEqualityProof @Int @Bool of-           UnsafeRefl (g :: Int ~# Bool) -> ...g...--     The simplifier normally eliminates case alternatives with-     contradicatory GADT data constructors; here we bring into-     scope evidence (g :: Int~Bool).  But we do not want to-     eliminate this particular alternative!  So we put a special-     case into DataCon.dataConCannotMatch to account for this.--(U7) We add a built-in RULE-       unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)-     to simplify the ase when the two tpyes are equal.--(U8) The is a super-magic RULE in GHC.base-         map coerce = coerce-     (see Note [Getting the map/coerce RULE to work] in CoreOpt)-     But it's all about turning coerce into a cast, and unsafeCoerce-     no longer does that.  So we need a separate map/unsafeCoerce-     RULE, in this module.--There are yet more wrinkles--(U9) unsafeCoerce works only over types of kind `Type`.-     But what about other types?  In Unsafe.Coerce we also define--      unsafeCoerceUnlifted :: forall (a :: TYPE UnliftedRep)-                                     (b :: TYPE UnliftedRep).-                              a -> b-      unsafeCoerceUnlifted x-        = case unsafeEqualityProof @a @b of-              UnsafeRefl -> x--     and similarly for unsafeCoerceAddr, unsafeCoerceInt, etc.--(U10) We also want a levity-polymorphic unsafeCoerce#:--       unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                        (a :: TYPE r1) (b :: TYPE r2).-                        a -> b--      This is even more dangerous, because it converts between two types-      *with different runtime representations*!!  Our goal is to deprecate-      it entirely.  But for now we want it.--      But having it is hard!  It is defined by a kind of stub in Unsafe.Coerce,-      and overwritten by the desugarer.  See Note [Wiring in unsafeCoerce#]-      in Desugar.  Here's the code for it-        unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of UnsafeRefl ->-                          case unsafeEqualityProof @a  @b  of UnsafeRefl ->-                          x-      Notice that we can define this kind-/heterogeneous/ function by calling-      the kind-/homogeneous/ unsafeEqualityProof twice.--      See Note [Wiring in unsafeCoerce#] in Desugar.--}---- | This type is treated magically within GHC. Any pattern match of the--- form @case unsafeEqualityProof of UnsafeRefl -> body@ gets transformed just into @body@.--- This is ill-typed, but the transformation takes place after type-checking is--- complete. It is used to implement 'unsafeCoerce'. You probably don't want to--- use 'UnsafeRefl' in an expression, but you might conceivably want to pattern-match--- on it. Use 'unsafeEqualityProof' to create one of these.-data UnsafeEquality a b where-  UnsafeRefl :: UnsafeEquality a a--{-# NOINLINE unsafeEqualityProof #-}-unsafeEqualityProof :: forall a b . UnsafeEquality a b--- See (U5) of Note [Implementing unsafeCoerce]-unsafeEqualityProof = case unsafeEqualityProof @a @b of UnsafeRefl -> UnsafeRefl--{-# INLINE [1] unsafeCoerce #-}--- The INLINE will almost certainly happen automatically, but it's almost--- certain to generate (slightly) better code, so let's do it.  For example------   case (unsafeCoerce blah) of ...------ will turn into------   case unsafeEqualityProof of UnsafeRefl -> case blah of ...------ which is definitely better.---- | Coerce a value from one type to another, bypassing the type-checker.------ There are several legitimate ways to use 'unsafeCoerce':------   1. To coerce e.g. @Int@ to @HValue@, put it in a list of @HValue@,---      and then later coerce it back to @Int@ before using it.------   2. To produce e.g. @(a+b) :~: (b+a)@ from @unsafeCoerce Refl@.---      Here the two sides really are the same type -- so nothing unsafe is happening---      -- but GHC is not clever enough to see it.------   3. In @Data.Typeable@ we have------      @---        eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).---                     TypeRep a -> TypeRep b -> Maybe (a :~~: b)---        eqTypeRep a b---          | sameTypeRep a b = Just (unsafeCoerce HRefl)---          | otherwise       = Nothing---      @------      Here again, the @unsafeCoerce HRefl@ is safe, because the two types really---      are the same  -- but the proof of that relies on the complex, trusted---      implementation of @Typeable@.------   4. The "reflection trick", which takes advantage of the fact that in---      @class C a where { op :: ty }@, we can safely coerce between @C a@ and @ty@---      (which have different kinds!) because it's really just a newtype.---      Note: there is /no guarantee, at all/ that this behavior will be supported---      into perpetuity.-unsafeCoerce :: forall (a :: Type) (b :: Type) . a -> b-unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x--unsafeCoerceUnlifted :: forall (a :: TYPE ('BoxedRep 'Unlifted)) (b :: TYPE ('BoxedRep 'Unlifted)) . a -> b--- Kind-homogeneous, but levity monomorphic (TYPE UnliftedRep)-unsafeCoerceUnlifted x = case unsafeEqualityProof @a @b of UnsafeRefl -> x--unsafeCoerceAddr :: forall (a :: TYPE 'AddrRep) (b :: TYPE 'AddrRep) . a -> b--- Kind-homogeneous, but levity monomorphic (TYPE AddrRep)-unsafeCoerceAddr x = case unsafeEqualityProof @a @b of UnsafeRefl -> x---- | Highly, terribly dangerous coercion from one representation type--- to another. Misuse of this function can invite the garbage collector--- to trounce upon your data and then laugh in your face. You don't want--- this function. Really.-unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                        (a :: TYPE r1) (b :: TYPE r2).-                 a -> b-unsafeCoerce# = error "GHC internal error: unsafeCoerce# not unfolded"--- See (U10) of Note [Implementing unsafeCorece]--- The RHS is updated by Desugar.patchMagicDefns--- See Desugar Note [Wiring in unsafeCoerce#]--{-# RULES--- See (U8) in Note [Implementing unsafeCoerce]---- unsafeCoerce version of the map/coerce rule defined in GHC.Base-"map/unsafeCoerce" map unsafeCoerce = unsafeCoerce---- unsafeCoerce version of the amap/coerce rule defined in GHC.Arr-"amap/unsafeCoerce" amap unsafeCoerce = unsafeCoerce- #-}
− aclocal.m4 
@@ -1,255 +0,0 @@-# FP_COMPUTE_INT(VARIABLE, EXPRESSION, INCLUDES, IF-FAILS)-# ---------------------------------------------------------# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for-# compilation. Execute IF-FAILS when unable to determine the value. Works for-# cross-compilation, too.-#-# Implementation note: We are lazy and use an internal autoconf macro, but it-# is supported in autoconf versions 2.50 up to the actual 2.57, so there is-# little risk.-# The public AC_COMPUTE_INT macro isn't supported by some versions of-# autoconf.-AC_DEFUN([FP_COMPUTE_INT],-[AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl-])# FP_COMPUTE_INT---# FP_CHECK_CONST(EXPRESSION, [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])-# --------------------------------------------------------------------------------# Defines CONST_EXPRESSION to the value of the compile-time EXPRESSION, using-# INCLUDES. If the value cannot be determined, use VALUE-IF-FAIL.-AC_DEFUN([FP_CHECK_CONST],-[AS_VAR_PUSHDEF([fp_Cache], [fp_cv_const_$1])[]dnl-AC_CACHE_CHECK([value of $1], fp_Cache,-[FP_COMPUTE_INT(fp_check_const_result, [$1], [AC_INCLUDES_DEFAULT([$2])],-                [fp_check_const_result=m4_default([$3], ['-1'])])-AS_VAR_SET(fp_Cache, [$fp_check_const_result])])[]dnl-AC_DEFINE_UNQUOTED(AS_TR_CPP([CONST_$1]), AS_VAR_GET(fp_Cache), [The value of $1.])[]dnl-AS_VAR_POPDEF([fp_Cache])[]dnl-])# FP_CHECK_CONST---# FP_CHECK_CONSTS_TEMPLATE(EXPRESSION...)-# ----------------------------------------# autoheader helper for FP_CHECK_CONSTS-m4_define([FP_CHECK_CONSTS_TEMPLATE],-[m4_foreach_w([fp_Const], [$1],-  [AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const),-               [The value of ]fp_Const[.])])[]dnl-])# FP_CHECK_CONSTS_TEMPLATE---# FP_CHECK_CONSTS(EXPRESSION..., [INCLUDES = DEFAULT-INCLUDES], [VALUE-IF-FAIL = -1])-# ------------------------------------------------------------------------------------# List version of FP_CHECK_CONST-AC_DEFUN([FP_CHECK_CONSTS],-[FP_CHECK_CONSTS_TEMPLATE([$1])dnl-for fp_const_name in $1-do-FP_CHECK_CONST([$fp_const_name], [$2], [$3])-done-])# FP_CHECK_CONSTS---dnl FPTOOLS_HTYPE_INCLUDES-AC_DEFUN([FPTOOLS_HTYPE_INCLUDES],-[-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-])---dnl ** Map an arithmetic C type to a Haskell type.-dnl    Based on autconf's AC_CHECK_SIZEOF.--dnl FPTOOLS_CHECK_HTYPE_ELSE(TYPE, WHAT_TO_DO_IF_TYPE_DOES_NOT_EXIST)-AC_DEFUN([FPTOOLS_CHECK_HTYPE_ELSE],[-    changequote(<<, >>)-    dnl The name to #define.-    define(<<AC_TYPE_NAME>>, translit(htype_$1, [a-z *], [A-Z_P]))-    dnl The cache variable names.-    define(<<AC_CV_NAME>>, translit(fptools_cv_htype_$1, [ *], [_p]))-    define(<<AC_CV_NAME_supported>>, translit(fptools_cv_htype_sup_$1, [ *], [_p]))-    changequote([, ])--    AC_MSG_CHECKING(Haskell type for $1)-    AC_CACHE_VAL(AC_CV_NAME,[-        AC_CV_NAME_supported=yes-        FP_COMPUTE_INT([HTYPE_IS_INTEGRAL],-                       [($1)0.2 - ($1)0.4 < 0 ? 0 : 1],-                       [FPTOOLS_HTYPE_INCLUDES],[HTYPE_IS_INTEGRAL=0])--        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-            dnl If the C type isn't an integer, we check if it's a pointer type-            dnl by trying to dereference one of its values. If that fails to-            dnl compile, it's not a pointer, so we check to see if it's a-            dnl floating-point type.-            AC_COMPILE_IFELSE(-                [AC_LANG_PROGRAM(-                    [FPTOOLS_HTYPE_INCLUDES],-                    [$1 val; *val;]-                )],-                [HTYPE_IS_POINTER=yes],-                [HTYPE_IS_POINTER=no])--            if test "$HTYPE_IS_POINTER" = yes-            then-                AC_CV_NAME="Ptr ()"-            else-                FP_COMPUTE_INT([HTYPE_IS_FLOAT],[sizeof($1) == sizeof(float)],-                               [FPTOOLS_HTYPE_INCLUDES],-                               [AC_CV_NAME_supported=no])-                FP_COMPUTE_INT([HTYPE_IS_DOUBLE],[sizeof($1) == sizeof(double)],-                               [FPTOOLS_HTYPE_INCLUDES],-                               [AC_CV_NAME_supported=no])-                FP_COMPUTE_INT([HTYPE_IS_LDOUBLE],[sizeof($1) == sizeof(long double)],-                               [FPTOOLS_HTYPE_INCLUDES],-                               [AC_CV_NAME_supported=no])-                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    AC_CV_NAME=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    AC_CV_NAME=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    AC_CV_NAME=LDouble-                else-                    AC_CV_NAME_supported=no-                fi-            fi-        else-            FP_COMPUTE_INT([HTYPE_IS_SIGNED],[(($1)(-1)) < (($1)0)],-                           [FPTOOLS_HTYPE_INCLUDES],-                           [AC_CV_NAME_supported=no])-            FP_COMPUTE_INT([HTYPE_SIZE],[sizeof($1) * 8],-                           [FPTOOLS_HTYPE_INCLUDES],-                           [AC_CV_NAME_supported=no])-            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                AC_CV_NAME="Word$HTYPE_SIZE"-            else-                AC_CV_NAME="Int$HTYPE_SIZE"-            fi-        fi-    ])-    if test "$AC_CV_NAME_supported" = no-    then-        $2-    fi--    dnl Note: evaluating dollar-2 can change the value of-    dnl $AC_CV_NAME_supported, so we might now get a different answer-    if test "$AC_CV_NAME_supported" = yes; then-        AC_MSG_RESULT($AC_CV_NAME)-        AC_DEFINE_UNQUOTED(AC_TYPE_NAME, $AC_CV_NAME,-                           [Define to Haskell type for $1])-    fi-    undefine([AC_TYPE_NAME])dnl-    undefine([AC_CV_NAME])dnl-    undefine([AC_CV_NAME_supported])dnl-])--dnl FPTOOLS_CHECK_HTYPE(TYPE)-AC_DEFUN([FPTOOLS_CHECK_HTYPE],[-    FPTOOLS_CHECK_HTYPE_ELSE([$1],[-        AC_CV_NAME=NotReallyAType-        AC_MSG_RESULT([not supported])-    ])-])---# FP_SEARCH_LIBS_PROTO(WHAT, PROTOTYPE, FUNCTION, SEARCH-LIBS,-#                [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],-#                [OTHER-LIBRARIES])-# ---------------------------------------------------------# Search for a library defining FUNC, if it's not already available.-# This is a copy of the AC_SEARCH_LIBS definition, but extended to take-# the name of the thing we are looking for as its first argument, and-# prototype text as its second argument. It also calls AC_LANG_PROGRAM-# instead of AC_LANG_CALL-AC_DEFUN([FP_SEARCH_LIBS_PROTO],-[AS_VAR_PUSHDEF([ac_Search], [ac_cv_search_$1])dnl-AC_CACHE_CHECK([for library containing $1], [ac_Search],-[ac_func_search_save_LIBS=$LIBS-AC_LANG_CONFTEST([AC_LANG_PROGRAM([$2], [$3])])-for ac_lib in '' $4; do-  if test -z "$ac_lib"; then-    ac_res="none required"-  else-    ac_res=-l$ac_lib-    LIBS="-l$ac_lib $7 $ac_func_search_save_LIBS"-  fi-  AC_LINK_IFELSE([], [AS_VAR_SET([ac_Search], [$ac_res])])-  AS_VAR_SET_IF([ac_Search], [break])-done-AS_VAR_SET_IF([ac_Search], , [AS_VAR_SET([ac_Search], [no])])-rm conftest.$ac_ext-LIBS=$ac_func_search_save_LIBS])-ac_res=AS_VAR_GET([ac_Search])-AS_IF([test "$ac_res" != no],-  [test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"-  $5],-      [$6])dnl-AS_VAR_POPDEF([ac_Search])dnl-])
− base.buildinfo.in 
@@ -1,4 +0,0 @@-extra-lib-dirs: @ICONV_LIB_DIRS@-extra-libraries: @EXTRA_LIBS@-include-dirs: @ICONV_INCLUDE_DIRS@-install-includes: HsBaseConfig.h EventConfig.h
base.cabal view
@@ -1,450 +1,320 @@ cabal-version:  3.0++-- WARNING: ghc-experimental.cabal is automatically generated from ghc-experimental.cabal.in+-- Make sure you are editing ghc-experimental.cabal.in, not ghc-experimental.cabal+ name:           base-version:        4.16.4.0+version:        4.22.0.0 -- NOTE: Don't forget to update ./changelog.md  license:        BSD-3-Clause license-file:   LICENSE-maintainer:     libraries@haskell.org-bug-reports:    https://gitlab.haskell.org/ghc/ghc/issues/new-synopsis:       Basic libraries+maintainer:     Core Libraries Committee <core-libraries-committee@haskell.org>+bug-reports:    https://github.com/haskell/core-libraries-committee/issues+synopsis:       Core data structures and operations category:       Prelude-build-type:     Configure-description:-    This package contains the Standard Haskell "Prelude" and its support libraries,-    and a large collection of useful libraries ranging from data-    structures to parsing combinators and debugging utilities.+build-type:     Simple+description:    Haskell's base library provides, among other things, core types (e.g. [Bool]("Data.Bool") and [Int]("Data.Int")),+                data structures (e.g. [List]("Data.List"), [Tuple]("Data.Tuple") and [Maybe]("Data.Maybe")),+                the [Exception]("Control.Exception") mechanism, and the [IO]("System.IO") & [Concurrency]("Control.Concurrent") operations.+                The "Prelude" module, which is imported by default, exposes a curated set of types and functions from other modules. -extra-tmp-files:-    autom4te.cache-    base.buildinfo-    config.log-    config.status-    include/EventConfig.h-    include/HsBaseConfig.h+                Other data structures like [Map](https://hackage.haskell.org/package/containers/docs/Data-Map.html),+                [Set](https://hackage.haskell.org/package/containers/docs/Data-Set.html) are available in the [containers](https://hackage.haskell.org/package/containers) library.+                To work with textual data, use the [text](https://hackage.haskell.org/package/text/docs/Data-Text.html) library. -extra-source-files:-    aclocal.m4-    base.buildinfo.in+extra-doc-files:     changelog.md-    config.guess-    config.sub-    configure-    configure.ac-    include/CTypes.h-    include/EventConfig.h.in-    include/HsBaseConfig.h.in-    include/ieee-flpt.h-    include/md5.h-    include/fs.h-    include/winio_structs.h-    install-sh -source-repository head-    type:     git-    location: https://gitlab.haskell.org/ghc/ghc.git-    subdir:   libraries/base- Library     default-language: Haskell2010-    other-extensions:-        BangPatterns-        CApiFFI-        CPP-        ConstraintKinds-        DataKinds-        DeriveDataTypeable-        DeriveGeneric-        ExistentialQuantification-        ExplicitForAll-        FlexibleContexts-        FlexibleInstances-        FunctionalDependencies-        GADTs-        GeneralizedNewtypeDeriving-        KindSignatures-        MagicHash-        MultiParamTypeClasses-        NegativeLiterals-        NoImplicitPrelude-        NondecreasingIndentation-        OverloadedStrings-        ParallelArrays-        PolyKinds-        RankNTypes-        RecordWildCards-        RoleAnnotations-        Safe-        ScopedTypeVariables-        StandaloneDeriving-        Trustworthy-        TypeFamilies-        TypeOperators-        TypeSynonymInstances-        UnboxedTuples-        UndecidableInstances-        UnliftedFFITypes-        Unsafe-+    default-extensions: NoImplicitPrelude     build-depends:-        rts == 1.0.*,-        ghc-prim >= 0.5.1.0 && < 0.9,-        ghc-bignum >= 1.0 && < 2.0+        ghc-internal == 9.1401.*,+        ghc-prim,      exposed-modules:-        Control.Applicative-        Control.Arrow-        Control.Category-        Control.Concurrent-        Control.Concurrent.Chan-        Control.Concurrent.MVar-        Control.Concurrent.QSem-        Control.Concurrent.QSemN-        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-        Control.Monad.ST.Lazy.Unsafe-        Control.Monad.ST.Safe-        Control.Monad.ST.Strict-        Control.Monad.ST.Unsafe-        Control.Monad.Zip-        Data.Bifoldable-        Data.Bifunctor-        Data.Bitraversable-        Data.Bits-        Data.Bool-        Data.Char-        Data.Coerce-        Data.Complex-        Data.Data-        Data.Dynamic-        Data.Either-        Data.Eq-        Data.Fixed-        Data.Foldable-        Data.Function-        Data.Functor-        Data.Functor.Classes-        Data.Functor.Contravariant-        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-        Data.String-        Data.Traversable-        Data.Tuple-        Data.Type.Bool-        Data.Type.Coercion-        Data.Type.Equality-        Data.Type.Ord-        Data.Typeable-        Data.Unique-        Data.Version-        Data.Void-        Data.Word-        Debug.Trace-        Foreign-        Foreign.C-        Foreign.C.Error-        Foreign.C.String-        Foreign.C.Types-        Foreign.Concurrent-        Foreign.ForeignPtr-        Foreign.ForeignPtr.Safe-        Foreign.ForeignPtr.Unsafe-        Foreign.Marshal-        Foreign.Marshal.Alloc-        Foreign.Marshal.Array-        Foreign.Marshal.Error-        Foreign.Marshal.Pool-        Foreign.Marshal.Safe-        Foreign.Marshal.Unsafe-        Foreign.Marshal.Utils-        Foreign.Ptr-        Foreign.Safe-        Foreign.StablePtr-        Foreign.Storable-        GHC.Arr-        GHC.Base-        GHC.Bits-        GHC.ByteOrder-        GHC.Char-        GHC.Clock-        GHC.Conc-        GHC.Conc.IO-        GHC.Conc.Signal-        GHC.Conc.Sync-        GHC.ConsoleHandler-        GHC.Constants-        GHC.Desugar-        GHC.Enum-        GHC.Environment-        GHC.Err-        GHC.Event.TimeOut-        GHC.Exception-        GHC.Exception.Type-        GHC.ExecutionStack-        GHC.ExecutionStack.Internal-        GHC.Exts-        GHC.Fingerprint-        GHC.Fingerprint.Type-        GHC.Float-        GHC.Float.ConversionUtils-        GHC.Float.RealFracMethods-        GHC.Foreign-        GHC.ForeignPtr-        GHC.GHCi-        GHC.GHCi.Helpers-        GHC.Generics-        GHC.IO-        GHC.IO.Buffer-        GHC.IO.BufferedIO-        GHC.IO.Device-        GHC.IO.Encoding-        GHC.IO.Encoding.CodePage-        GHC.IO.Encoding.Failure-        GHC.IO.Encoding.Iconv-        GHC.IO.Encoding.Latin1-        GHC.IO.Encoding.Types-        GHC.IO.Encoding.UTF16-        GHC.IO.Encoding.UTF32-        GHC.IO.Encoding.UTF8-        GHC.IO.Exception-        GHC.IO.FD-        GHC.IO.Handle-        GHC.IO.Handle.FD-        GHC.IO.Handle.Internals-        GHC.IO.Handle.Lock-        GHC.IO.Handle.Text-        GHC.IO.Handle.Types-        GHC.IO.IOMode-        GHC.IO.Unsafe-        GHC.IO.StdHandles-        GHC.IO.SubSystem-        GHC.IOArray-        GHC.IORef-        GHC.Int-        GHC.Integer-        GHC.Integer.Logarithms-        GHC.Ix-        GHC.List-        GHC.Maybe-        GHC.MVar-        GHC.Natural-        GHC.Num-        GHC.OldList-        GHC.OverloadedLabels-        GHC.Pack-        GHC.Profiling-        GHC.Ptr-        GHC.Read-        GHC.Real-        GHC.Records-        GHC.ResponseFile-        GHC.RTS.Flags-        GHC.ST-        GHC.StaticPtr-        GHC.STRef-        GHC.Show-        GHC.Stable-        GHC.StableName-        GHC.Stack-        GHC.Stack.CCS-        GHC.Stack.Types-        GHC.Stats-        GHC.Storable-        GHC.TopHandler-        GHC.TypeLits-        GHC.TypeLits.Internal-        GHC.TypeNats-        GHC.TypeNats.Internal-        GHC.Unicode-        GHC.Weak-        GHC.Word-        Numeric-        Numeric.Natural-        Prelude-        System.CPUTime-        System.Console.GetOpt-        System.Environment-        System.Environment.Blank-        System.Exit-        System.IO-        System.IO.Error-        System.IO.Unsafe-        System.Info-        System.Mem-        System.Mem.StableName-        System.Mem.Weak-        System.Posix.Internals-        System.Posix.Types-        System.Timeout-        Text.ParserCombinators.ReadP-        Text.ParserCombinators.ReadPrec-        Text.Printf-        Text.Read-        Text.Read.Lex-        Text.Show-        Text.Show.Functions-        Type.Reflection-        Type.Reflection.Unsafe-        Unsafe.Coerce-        -- TODO: remove-        GHC.IOPort+          Control.Applicative+        , Control.Concurrent+        , Control.Concurrent.Chan+        , Control.Concurrent.QSem+        , Control.Concurrent.QSemN+        , Control.Monad.IO.Class+        , Control.Monad.Zip+        , Data.Array.Byte+        , Data.Bifoldable+        , Data.Bifoldable1+        , Data.Bifunctor+        , Data.Bitraversable+        , Data.Bounded+        , Data.Char+        , Data.Complex+        , Data.Enum+        , Data.Fixed+        , Data.Foldable1+        , Data.Functor.Classes+        , Data.Functor.Compose+        , Data.Functor.Contravariant+        , Data.Functor.Sum+        , Data.Functor.Product+        , Data.List.NonEmpty+        , Data.Ratio+        , Data.STRef.Lazy+        , Data.Semigroup+        , Prelude+        , Text.Printf+        , System.CPUTime+        , System.Console.GetOpt+        , System.IO.Unsafe+        , System.Info+        , System.Mem.Weak+        , System.Timeout -    reexported-modules:-          GHC.Num.Integer+    exposed-modules:+        , Control.Arrow+        , Control.Category+        , Control.Concurrent.MVar+        , Control.Exception+        , Control.Exception.Annotation+        , Control.Exception.Backtrace+        , Control.Exception.Base+        , Control.Exception.Context+        , Control.Monad+        , Control.Monad.Fail+        , Control.Monad.Fix+        , Control.Monad.Instances+        , Control.Monad.ST+        , Control.Monad.ST.Lazy+        , Control.Monad.ST.Lazy.Safe+        , Control.Monad.ST.Lazy.Unsafe+        , Control.Monad.ST.Safe+        , Control.Monad.ST.Strict+        , Control.Monad.ST.Unsafe+        , Data.Bits+        , Data.Bool+        , Data.Coerce+        , Data.Data+        , Data.Dynamic+        , Data.Either+        , Data.Eq+        , Data.Foldable+        , Data.Function+        , Data.Functor+        , Data.Functor.Const+        , Data.Functor.Identity+        , Data.IORef+        , Data.Int+        , Data.Ix+        , Data.Kind+        , Data.List+        , Data.Maybe+        , Data.Monoid+        , Data.Ord+        , Data.Proxy+        , Data.STRef+        , Data.STRef.Strict+        , Data.String+        , Data.Traversable+        , Data.Tuple+        , Data.Type.Bool+        , Data.Type.Coercion+        , Data.Type.Equality+        , Data.Type.Ord+        , Data.Typeable+        , Data.Unique+        , Data.Version+        , Data.Void+        , Data.Word+        , Debug.Trace+        , Foreign+        , Foreign.C+        , Foreign.C.ConstPtr+        , Foreign.C.Error+        , Foreign.C.String+        , Foreign.C.Types+        , Foreign.Concurrent+        , Foreign.ForeignPtr+        , Foreign.ForeignPtr.Safe+        , Foreign.ForeignPtr.Unsafe+        , Foreign.Marshal+        , Foreign.Marshal.Alloc+        , Foreign.Marshal.Array+        , Foreign.Marshal.Error+        , Foreign.Marshal.Pool+        , Foreign.Marshal.Safe+        , Foreign.Marshal.Unsafe+        , Foreign.Marshal.Utils+        , Foreign.Ptr+        , Foreign.Safe+        , Foreign.StablePtr+        , Foreign.Storable+        , GHC.Arr+        , GHC.ArrayArray+        , GHC.Base+        , GHC.Bits+        , GHC.ByteOrder+        , GHC.Char+        , GHC.Clock+        , GHC.Conc+        , GHC.Conc.IO+        , GHC.Conc.Signal+        , GHC.Conc.Sync+        , GHC.ConsoleHandler+        , GHC.Constants+        , GHC.Desugar+        , GHC.Encoding.UTF8+        , GHC.Enum+        , GHC.Environment+        , GHC.Err+        , GHC.Event.TimeOut+        , GHC.Exception+        , GHC.Exception.Type+        , GHC.ExecutionStack+        , GHC.Exts+        , GHC.Fingerprint+        , GHC.Fingerprint.Type+        , GHC.Float+        , GHC.Float.ConversionUtils+        , GHC.Float.RealFracMethods+        , GHC.Foreign+        , GHC.ForeignPtr+        , GHC.GHCi+        , GHC.GHCi.Helpers+        , GHC.Generics+        , GHC.InfoProv+        , GHC.IO+        , GHC.IO.Buffer+        , GHC.IO.BufferedIO+        , GHC.IO.Device+        , GHC.IO.Encoding+        , GHC.IO.Encoding.CodePage+        , GHC.IO.Encoding.Failure+        , GHC.IO.Encoding.Iconv+        , GHC.IO.Encoding.Latin1+        , GHC.IO.Encoding.Types+        , GHC.IO.Encoding.UTF16+        , GHC.IO.Encoding.UTF32+        , GHC.IO.Encoding.UTF8+        , GHC.IO.Exception+        , GHC.IO.FD+        , GHC.IO.Handle+        , GHC.IO.Handle.FD+        , GHC.IO.Handle.Internals+        , GHC.IO.Handle.Lock+        , GHC.IO.Handle.Text+        , GHC.IO.Handle.Types+        , GHC.IO.IOMode+        , GHC.IO.Unsafe+        , GHC.IO.StdHandles+        , GHC.IO.SubSystem+        , GHC.IOArray+        , GHC.IORef+        , GHC.Int+        , GHC.Integer+        , GHC.Integer.Logarithms+        , GHC.IsList+        , GHC.Ix+        , GHC.List+        , GHC.Maybe+        , GHC.MVar+        , GHC.Natural+        , GHC.Num+        , GHC.Num.Integer         , GHC.Num.Natural         , GHC.Num.BigNat--    other-modules:-        Control.Monad.ST.Imp-        Control.Monad.ST.Lazy.Imp-        Data.Functor.Utils-        Data.OldList-        Data.Semigroup.Internal-        Data.Typeable.Internal-        Foreign.ForeignPtr.Imp-        GHC.IO.Handle.Lock.Common-        GHC.IO.Handle.Lock.Flock-        GHC.IO.Handle.Lock.LinuxOFD-        GHC.IO.Handle.Lock.NoOp-        GHC.IO.Handle.Lock.Windows-        GHC.StaticPtr.Internal-        GHC.Event.Arr-        GHC.Event.Array-        GHC.Event.Internal-        GHC.Event.Internal.Types-        GHC.Event.IntTable-        GHC.Event.IntVar-        GHC.Event.PSQ-        GHC.Event.Unique-        -- GHC.IOPort -- TODO: hide again after debug-        System.Environment.ExecutablePath-        System.CPUTime.Utils--    c-sources:-        cbits/DarwinUtils.c-        cbits/PrelIOUtils.c-        cbits/SetEnv.c-        cbits/WCsubst.c-        cbits/iconv.c-        cbits/inputReady.c-        cbits/md5.c-        cbits/primFloat.c-        cbits/sysconf.c-        cbits/fs.c--    cmm-sources:-        cbits/CastFloatWord.cmm--    include-dirs: include-    includes:-        HsBase.h-    install-includes:-        HsBase.h-        WCsubst.h-        consUtils.h+        , GHC.OldList+        , GHC.OverloadedLabels+        , GHC.Profiling+        , GHC.Ptr+        , GHC.Read+        , GHC.Real+        , GHC.Records+        , GHC.ResponseFile+        , GHC.RTS.Flags+        , GHC.ST+        , GHC.Stack.CloneStack+        , GHC.StaticPtr+        , GHC.STRef+        , GHC.Show+        , GHC.Stable+        , GHC.StableName+        , GHC.Stack+        , GHC.Stack.CCS+        , GHC.Stack.Types+        , GHC.Stats+        , GHC.Storable+        , GHC.TopHandler+        , GHC.TypeError+        , GHC.TypeLits+        , GHC.TypeNats+        , GHC.Unicode+        , GHC.Weak+        , GHC.Weak.Finalize+        , GHC.Word+        , Numeric+        , Numeric.Natural+        , System.Environment+        , System.Environment.Blank+        , System.Exit+        , System.IO+        , System.IO.Error+        , System.Mem+        , System.Mem.StableName+        , System.Posix.Internals+        , System.Posix.Types+        , Text.ParserCombinators.ReadP+        , Text.ParserCombinators.ReadPrec+        , Text.Read+        , Text.Read.Lex+        , Text.Show+        , Text.Show.Functions+        , Type.Reflection+        , Type.Reflection.Unsafe+        , Unsafe.Coerce -    -- OS Specific     if os(windows)-        -- 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.-        -- shlwapi: provides PathFileExistsW-        -- ws2_32: provides access to socket types and functions-        -- ole32: provides UUID functionality.-        -- rpcrt4: provides RPC UUID creation.-        -- ntdll: provides access to functions to inspect window handles-        extra-libraries: wsock32, user32, shell32, msvcrt, mingw32,-                         mingwex, ws2_32, shlwapi, ole32, rpcrt4, ntdll-        -- Minimum supported Windows version.-        -- These numbers can be found at:-        --  https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx-        -- If we're compiling on windows, enforce that we only support Windows 7+-        -- Adding this here means it doesn't have to be done in individual .c files-        -- and also centralizes the versioning.-        cpp-options: -D_WIN32_WINNT=0x06010000-        cc-options: -D_WIN32_WINNT=0x06010000         exposed-modules:-            GHC.IO.Encoding.CodePage.API-            GHC.IO.Encoding.CodePage.Table-            GHC.Conc.Windows-            GHC.Conc.WinIO-            GHC.Conc.POSIX-            GHC.Conc.POSIX.Const-            GHC.Windows-            GHC.Event.Windows-            GHC.Event.Windows.Clock-            GHC.Event.Windows.ConsoleEvent-            GHC.Event.Windows.FFI-            GHC.Event.Windows.ManagedThreadPool-            GHC.Event.Windows.Thread-            GHC.IO.Handle.Windows-            GHC.IO.Windows.Handle-            GHC.IO.Windows.Encoding-            GHC.IO.Windows.Paths-        other-modules:-            System.CPUTime.Windows-        c-sources:-            cbits/Win32Utils.c-            cbits/consUtils.c-            cbits/IOutils.c-+              GHC.IO.Encoding.CodePage.API+            , GHC.IO.Encoding.CodePage.Table+            , GHC.Conc.Windows+            , GHC.Conc.WinIO+            , GHC.Conc.POSIX+            , GHC.Conc.POSIX.Const+            , GHC.Windows+            , GHC.Event.Windows+            , GHC.Event.Windows.Clock+            , GHC.Event.Windows.ConsoleEvent+            , GHC.Event.Windows.FFI+            , GHC.Event.Windows.ManagedThreadPool+            , GHC.Event.Windows.Thread+            , GHC.IO.Handle.Windows+            , GHC.IO.Windows.Handle+            , GHC.IO.Windows.Encoding+            , GHC.IO.Windows.Paths     else         exposed-modules:             GHC.Event-        other-modules:-            GHC.Event.Control-            GHC.Event.EPoll-            GHC.Event.KQueue-            GHC.Event.Manager-            GHC.Event.Poll-            GHC.Event.Thread-            GHC.Event.TimerManager -            System.CPUTime.Posix.ClockGetTime-            System.CPUTime.Posix.Times-            System.CPUTime.Posix.RUsage-            System.CPUTime.Unsupported--    -- The Ports framework always passes this flag when building software that-    -- uses iconv to make iconv from Ports compatible with iconv from the base system-    -- See /usr/ports/Mk/Uses/iconv.mk-    if os(freebsd)-        cc-options: -DLIBICONV_PLUG+    if arch(javascript)+        exposed-modules:+              GHC.JS.Prim+            , GHC.JS.Prim.Internal+            , GHC.JS.Prim.Internal.Build+            , GHC.JS.Foreign.Callback -    -- We need to set the unit id to base (without a version number)-    -- as it's magic.-    ghc-options: -this-unit-id base+    other-modules:+        System.CPUTime.Unsupported+        System.CPUTime.Utils+    if os(windows)+      other-modules:+        System.CPUTime.Windows+    elif arch(javascript)+      other-modules:+        System.CPUTime.Javascript+    else+      other-modules:+        System.CPUTime.Posix.ClockGetTime+        System.CPUTime.Posix.Times+        System.CPUTime.Posix.RUsage -    -- Make sure we don't accidentally regress into anti-patterns-    ghc-options: -Wcompat -Wnoncanonical-monad-instances+    hs-source-dirs: src
− cbits/CastFloatWord.cmm 
@@ -1,70 +0,0 @@-#include "Cmm.h"-#include "MachDeps.h"--#if WORD_SIZE_IN_BITS == 64-#define DOUBLE_SIZE_WDS   1-#else-#define DOUBLE_SIZE_WDS   2-#endif--stg_word64ToDoublezh(I64 w)-{-    D_ d;-    P_ ptr;--    STK_CHK_GEN_N (DOUBLE_SIZE_WDS);--    reserve DOUBLE_SIZE_WDS = ptr {-        I64[ptr] = w;-        d = D_[ptr];-    }--    return (d);-}--stg_doubleToWord64zh(D_ d)-{-    I64 w;-    P_ ptr;--    STK_CHK_GEN_N (DOUBLE_SIZE_WDS);--    reserve DOUBLE_SIZE_WDS = ptr {-        D_[ptr] = d;-        w = I64[ptr];-    }--    return (w);-}--stg_word32ToFloatzh(W_ w)-{-    F_ f;-    P_ ptr;--    STK_CHK_GEN_N (1);--    reserve 1 = ptr {-        I32[ptr] = %lobits32(w);-        f = F_[ptr];-    }--    return (f);-}--stg_floatToWord32zh(F_ f)-{-    W_ w;-    P_ ptr;--    STK_CHK_GEN_N (1);--    reserve 1 = ptr {-        F_[ptr] = f;-        // Fix #16617: use zero-extending (TO_ZXW_) here-        w = TO_ZXW_(I32[ptr]);-    }--    return (w);-}-
− cbits/DarwinUtils.c 
@@ -1,22 +0,0 @@-#include "HsBase.h"--#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)-#include <mach/mach_time.h>--static double scaling_factor = 0.0;--void initialize_timer()-{-    mach_timebase_info_data_t info;-    (void) mach_timebase_info(&info);-    scaling_factor = (double)info.numer / (double)info.denom;-    scaling_factor *= 1e-9;-}--void absolute_time(double *result)-{-    uint64_t time = mach_absolute_time();-    *result = (double)time * scaling_factor;-}--#endif
− cbits/IOutils.c 
@@ -1,484 +0,0 @@-/*- * (c) The GHC Team 2017-2018.- *- * I/O Utility functions for Windows.- */--#include <stdbool.h>-#include <stdint.h>-#include <winsock2.h>-#include <windows.h>-#include <io.h>-#include <math.h>--/* Import some functions defined in base.  */-extern void maperrno(void);--/* Enum of Handle type.  */-typedef-enum HandleType-  {-    TYPE_CHAR,   // 0-    TYPE_DISK,   // 1-    TYPE_PIPE,   // 2-    TYPE_SOCKET, // 3-    TYPE_REMOTE, // 4-    TYPE_RAW,    // 5-    TYPE_UNKNOWN // 6-  } HANDLE_TYPE;--/*- * handleReady(hwnd) checks to see whether input is available on the file- * handle 'hwnd'.  Input meaning 'can I safely read at least a- * *character* from this file object without blocking?'- */-int-__handle_ready(HANDLE hFile, bool write, int msecs)-{-    DWORD handleType = GetFileType (hFile);--    DWORD rc;-        DWORD avail;--    switch (handleType)-      {-        case FILE_TYPE_CHAR:-        {-            INPUT_RECORD buf[1];-            DWORD count;--            /* A Console Handle will appear to be ready-             (WaitForSingleObject() returned WAIT_OBJECT_0) when-             it has events in its input buffer, but these events might-             not be keyboard events, so when we read from the Handle the-             read() will block.  So here we try to discard non-keyboard-             events from a console handle's input buffer and then try-             the WaitForSingleObject() again.-             Phyx: I'm worried that we're discarding events someone else may need.  */-            while (true) // keep trying until we find a real key event-            {-                rc = WaitForSingleObject( hFile, msecs );-                switch (rc)-                  {-                    case WAIT_TIMEOUT:-                        return false;-                    case WAIT_OBJECT_0:-                        break;-                    default:-                        /* WAIT_FAILED */-                        maperrno();-                        return -1;-                  }--                while (true) // discard non-key events-                {-                    /* I wonder if we can do better by grabbing a list of-                       input records at a time by using PeekConsoleInput.  */-                    rc = PeekConsoleInput(hFile, buf, 1, &count);-                    if (rc == 0) {-                        rc = GetLastError();-                        if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION)-                            return true;-                        else {-                            maperrno();-                            return -1;-                        }-                    }--                    if (count == 0)-                        break; /* no more events => wait again.  */--                    /* discard console events that are not "key down", because-                       these will also be discarded by ReadFile().  */-                    if (buf[0].EventType == KEY_EVENT &&-                        buf[0].Event.KeyEvent.bKeyDown &&-                        buf[0].Event.KeyEvent.uChar.AsciiChar != '\0')-                          return true; /* it's a proper keypress.  */-                    else-                    {-                        /* it's a non-key event, a key up event, or a-                           non-character key (e.g. shift).  discard it.  */-                        rc = ReadConsoleInput(hFile, buf, 1, &count);-                        if (rc == 0) {-                            rc = GetLastError();-                            if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION)-                                return true;-                            else {-                                maperrno();-                                return -1;-                            }-                        }-                    }-                }-            }-        }-        case FILE_TYPE_DISK:-            /* assume that disk files are always ready.  */-            return true;--        case FILE_TYPE_PIPE:-        {-            // Try to see if this is a socket-            //--------------------------            // Create new event-            WSAEVENT newEvent = WSACreateEvent();--            //--------------------------            // Associate event types FD_WRITE or FD_READ-            // with the listening socket and NewEvent-            rc = WSAEventSelect((SOCKET)hFile, newEvent, write ? FD_WRITE : FD_READ);--            if (rc == WSAENOTSOCK)-            {-                CloseHandle (newEvent);--                // WaitForMultipleObjects() doesn't work for pipes (it-                // always returns WAIT_OBJECT_0 even when no data is-                // available).  If the HANDLE is a pipe, therefore, we try-                // PeekNamedPipe:-                //-                rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL );-                if (rc != 0)-                    return avail != 0;-                else {-                    rc = GetLastError();-                    if (rc == ERROR_BROKEN_PIPE)-                        return true; // this is probably what we want--                    if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) {-                        maperrno();-                        return -1;-                    }-                }-                /* PeekNamedPipe didn't work - fall through to the general case */-            }-            else if (rc != 0)-            {-                CloseHandle (newEvent);-                // It seems to be a socket but can't determine the state.-                // Maybe not initialized. Either way, we know enough.-                return false;-            }--            // Wait for the socket event to trigger.-            rc = WaitForSingleObject( newEvent, msecs );-            CloseHandle (newEvent);--            /* 1 => Input ready, 0 => not ready, -1 => error */-            switch (rc)-              {-                case WAIT_TIMEOUT:-                    return false;-                case WAIT_OBJECT_0:-                    return true;-                default:-                {-                    /* WAIT_FAILED */-                    maperrno();-                    return -1;-                }-              }-        }-        default:-            rc = WaitForSingleObject( hFile, msecs );--            /* 1 => Input ready, 0 => not ready, -1 => error */-            switch (rc)-              {-                case WAIT_TIMEOUT:-                    return false;-                case WAIT_OBJECT_0:-                    return true;-                default:-                {-                    /* WAIT_FAILED */-                    maperrno();-                    return -1;-                }-              }-      }-}--bool-__is_console(HANDLE hFile)-{-    /* Broken handle can't be terminal */-    if (hFile == INVALID_HANDLE_VALUE)-        return false;--    DWORD handleType = GetFileType (hFile);--    /* TTY must be a character device */-    if (handleType != FILE_TYPE_CHAR)-        return false;--    DWORD st;-    /* GetConsoleMode appears to fail when it's not a TTY.  In-       particular, it's what most of our terminal functions-       assume works, so if it doesn't work for all intents-       and purposes we're not dealing with a terminal. */-    if (!GetConsoleMode(hFile, &st)) {-        /* Clear the error buffer before returning.  */-        SetLastError (ERROR_SUCCESS);-        return false;-    }--    return true;-}--#if !defined(ENABLE_VIRTUAL_TERMINAL_INPUT)-#define ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200-#endif--bool-__set_console_buffering(HANDLE hFile, bool cooked)-{-    if (hFile == INVALID_HANDLE_VALUE) {-        return false;-    }--    DWORD  st;-    if (!GetConsoleMode(hFile, &st)) {-        return false;-    }--    /* According to GetConsoleMode() docs, it is not possible to-       leave ECHO_INPUT enabled without also having LINE_INPUT,-       so we have to turn both off here.-       We toggle ENABLE_VIRTUAL_TERMINAL_INPUT to enable us to receive-       virtual keyboard keys in ReadConsole.  */-    DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;-    DWORD enabled = (st & ~flgs) | ENABLE_VIRTUAL_TERMINAL_INPUT;-    DWORD disabled = (st | ENABLE_LINE_INPUT) & ~ENABLE_VIRTUAL_TERMINAL_INPUT;---        return SetConsoleMode(hFile, cooked ? enabled : disabled);-}--bool-__set_console_echo(HANDLE hFile, bool on)-{-    DWORD  st;-    DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;--    if (hFile == INVALID_HANDLE_VALUE) {-        return false;-    }--        return GetConsoleMode(hFile, &st) &&-               SetConsoleMode(hFile, ( on ? (st | flgs) : (st & ~flgs)));-}--bool-__get_console_echo(HANDLE hFile)-{-    DWORD  st;--    if (hFile == INVALID_HANDLE_VALUE) {-        return false;-    }--        return GetConsoleMode(hFile, &st) &&-               (st & ENABLE_ECHO_INPUT) == ENABLE_ECHO_INPUT;-}--bool-__flush_input_console(HANDLE hFile)-{-    if ( hFile == INVALID_HANDLE_VALUE )-      return false;--        /* If the 'handle' isn't connected to a console; treat the flush-         * operation as a NOP.-         */-        DWORD unused;-        if ( !GetConsoleMode(hFile, &unused) &&-             GetLastError() == ERROR_INVALID_HANDLE ) {-            return false;-        }--        if ( FlushConsoleInputBuffer(hFile) )-            return true;--    maperrno();-    return false;-}--HANDLE_TYPE-__handle_type (HANDLE hFile)-{-    DWORD handleType = GetFileType (hFile);-    switch (handleType)-      {-        case FILE_TYPE_PIPE:-          {-            WSAEVENT newEvent = WSACreateEvent();-            DWORD rc = WSAEventSelect((SOCKET)hFile, newEvent, FD_CLOSE);-            CloseHandle (newEvent);-            if (rc == WSAENOTSOCK)-              return TYPE_SOCKET;-            else-              return TYPE_PIPE;-          }-        case FILE_TYPE_CHAR:-          return TYPE_CHAR;-        case FILE_TYPE_DISK:-          return TYPE_DISK;-        case FILE_TYPE_REMOTE:-          return TYPE_REMOTE;-        case FILE_TYPE_UNKNOWN:-        default:-          return TYPE_UNKNOWN;-      }-}--bool-__close_handle (HANDLE hFile)-{-    switch (__handle_type (hFile))-      {-        case TYPE_SOCKET:-            return closesocket ((SOCKET)hFile) == 0;-        default:-            return CloseHandle (hFile);-      }-}--bool __set_file_pointer (HANDLE hFile, int64_t pos, DWORD moveMethod,-                         int64_t* outPos)-{-    LARGE_INTEGER ret;-    LARGE_INTEGER li;-    li.QuadPart = pos;-    bool success = SetFilePointerEx (hFile, li, &ret, moveMethod)-                    != INVALID_SET_FILE_POINTER;-    *outPos = ret.QuadPart;-    return success;-}--int64_t __get_file_pointer (HANDLE hFile)-{-    LARGE_INTEGER ret;-    LARGE_INTEGER pos;-    pos.QuadPart = 0;-    if (SetFilePointerEx(hFile, pos, &ret, FILE_CURRENT)-        == INVALID_SET_FILE_POINTER)-      return -1;--    return ret.QuadPart;-}--int64_t __get_file_size (HANDLE hFile)-{-    /* Broken handle can't do stat.  */-    if (hFile == INVALID_HANDLE_VALUE)-        return false;--    switch (GetFileType (hFile))-    {-      case FILE_TYPE_CHAR:-      case FILE_TYPE_DISK:-        break;-      default:-        return -1;-    }--    LARGE_INTEGER ret;-    if (!GetFileSizeEx(hFile, &ret))-      return -1;--    return ret.QuadPart;-}--bool __set_file_size (HANDLE hFile, int64_t size)-{-    LARGE_INTEGER li;-    li.QuadPart = size;-    if(!SetFilePointerEx (hFile, li, NULL, FILE_BEGIN))-        return false;--    return SetEndOfFile (hFile);-}--bool __duplicate_handle (HANDLE hFile, HANDLE* hFileDup)-{-    switch (__handle_type (hFile))-    {-        case TYPE_SOCKET:-            // should use WSADuplicateSocket-            return false;-        default:-            return DuplicateHandle(GetCurrentProcess(),-                                hFile,-                                GetCurrentProcess(),-                                hFileDup,-                                0,-                                FALSE,-                                DUPLICATE_SAME_ACCESS);-    }-}--bool __set_console_pointer (HANDLE hFile, int64_t pos, DWORD moveMethod,-                            int64_t* outPos)-{-    CONSOLE_SCREEN_BUFFER_INFO info;-    if(!GetConsoleScreenBufferInfo (hFile, &info))-        return false;--    COORD point;-    switch (moveMethod)-    {-        case FILE_END:-          {-              int64_t end = info.dwSize.X * info.dwSize.Y;-              pos = end + pos;-              point = (COORD) { pos % info.dwSize.X, pos / info.dwSize.X };-              break;-          }-        case FILE_CURRENT:-          {-              int64_t current = (info.dwCursorPosition.Y * info.dwSize.X)-                              + info.dwCursorPosition.X;-              pos = current + pos;-              point = (COORD) { pos % info.dwSize.X, pos / info.dwSize.X };-              break;-          }-        case FILE_BEGIN:-        default:-          point = (COORD) { pos % info.dwSize.X, pos / info.dwSize.X };-          break;-    }--    *outPos = pos;-    return SetConsoleCursorPosition (hFile, point);-}--int64_t __get_console_pointer (HANDLE hFile)-{-    CONSOLE_SCREEN_BUFFER_INFO info;-    if(!GetConsoleScreenBufferInfo (hFile, &info))-        return -1;--    return (info.dwCursorPosition.Y * info.dwSize.X) + info.dwCursorPosition.X;-}--int64_t __get_console_buffer_size (HANDLE hFile)-{-    CONSOLE_SCREEN_BUFFER_INFO ret;-    if (!GetConsoleScreenBufferInfo(hFile, &ret))-      return -1;--    return ret.dwSize.X * ret.dwSize.Y;-}--bool __set_console_buffer_size (HANDLE hFile, int64_t size)-{-    CONSOLE_SCREEN_BUFFER_INFO ret;-    if (!GetConsoleScreenBufferInfo(hFile, &ret))-      return false;--    COORD sz = {ret.dwSize.X, (int)ceil(size / ret.dwSize.X)};-    return SetConsoleScreenBufferSize (hFile, sz);-}--
− cbits/PrelIOUtils.c 
@@ -1,45 +0,0 @@-/*- * (c) The University of Glasgow 2002- *- * static versions of the inline functions in HsBase.h- */--#define INLINE--#include "Rts.h"-#include "HsBase.h"--void errorBelch2(const char*s, char *t)-{-    errorBelch(s,t);-}--void debugBelch2(const char*s, char *t)-{-    debugBelch(s,t);-}--#if defined(HAVE_LIBCHARSET)-#  include <libcharset.h>-#elif defined(HAVE_LANGINFO_H)-#  include <langinfo.h>-#endif--#if !defined(mingw32_HOST_OS)-const char* localeEncoding(void)-{-#if defined(HAVE_LIBCHARSET)-    return locale_charset();--#elif defined(HAVE_LANGINFO_H)-    return nl_langinfo(CODESET);--#else-#warning Depending on the unportable behavior of GNU iconv due to absence of both libcharset and langinfo.h-    /* GNU iconv accepts "" to mean the current locale's-     * encoding. Warning: This isn't portable.-     */-    return "";-#endif-}-#endif
− cbits/SetEnv.c 
@@ -1,11 +0,0 @@-#include "HsBase.h"-#if defined(HAVE_UNSETENV)-int __hsbase_unsetenv(const char *name) {-#if defined(UNSETENV_RETURNS_VOID)-    unsetenv(name);-    return 0;-#else-    return unsetenv(name);-#endif-}-#endif
− cbits/WCsubst.c 
@@ -1,5238 +0,0 @@-/*--------------------------------------------------------------------------This is an automatically generated file: do not edit-Generated by ubconfc at Fri Sep 24 05:07:27 PM EDT 2021-@generated--------------------------------------------------------------------------*/--#include "WCsubst.h"--/* Unicode general categories, listed in the same order as in the Unicode- * standard -- this must be the same order as in GHC.Unicode.- */--enum {-    NUMCAT_LU,  /* Letter, Uppercase */-    NUMCAT_LL,  /* Letter, Lowercase */-    NUMCAT_LT,  /* Letter, Titlecase */-    NUMCAT_LM,  /* Letter, Modifier */-    NUMCAT_LO,  /* Letter, Other */-    NUMCAT_MN,  /* Mark, Non-Spacing */-    NUMCAT_MC,  /* Mark, Spacing Combining */-    NUMCAT_ME,  /* Mark, Enclosing */-    NUMCAT_ND,  /* Number, Decimal */-    NUMCAT_NL,  /* Number, Letter */-    NUMCAT_NO,  /* Number, Other */-    NUMCAT_PC,  /* Punctuation, Connector */-    NUMCAT_PD,  /* Punctuation, Dash */-    NUMCAT_PS,  /* Punctuation, Open */-    NUMCAT_PE,  /* Punctuation, Close */-    NUMCAT_PI,  /* Punctuation, Initial quote */-    NUMCAT_PF,  /* Punctuation, Final quote */-    NUMCAT_PO,  /* Punctuation, Other */-    NUMCAT_SM,  /* Symbol, Math */-    NUMCAT_SC,  /* Symbol, Currency */-    NUMCAT_SK,  /* Symbol, Modifier */-    NUMCAT_SO,  /* Symbol, Other */-    NUMCAT_ZS,  /* Separator, Space */-    NUMCAT_ZL,  /* Separator, Line */-    NUMCAT_ZP,  /* Separator, Paragraph */-    NUMCAT_CC,  /* Other, Control */-    NUMCAT_CF,  /* Other, Format */-    NUMCAT_CS,  /* Other, Surrogate */-    NUMCAT_CO,  /* Other, Private Use */-    NUMCAT_CN   /* Other, Not Assigned */-};--struct _convrule_ -{ -	unsigned int category;-	unsigned int catnumber;-	int possible;-	int updist;-	int lowdist; -	int titledist;-};--struct _charblock_ -{ -	int start;-	int length;-	const struct _convrule_ *rule;-};--#define GENCAT_ZP 67108864-#define GENCAT_MC 8388608-#define GENCAT_NO 131072-#define GENCAT_SK 1024-#define GENCAT_CO 268435456-#define GENCAT_ME 4194304-#define GENCAT_ND 256-#define GENCAT_PO 4-#define GENCAT_LT 524288-#define GENCAT_PC 2048-#define GENCAT_SM 64-#define GENCAT_ZS 2-#define GENCAT_CC 1-#define GENCAT_LU 512-#define GENCAT_PD 128-#define GENCAT_SO 8192-#define GENCAT_PE 32-#define GENCAT_CS 134217728-#define GENCAT_PF 262144-#define GENCAT_CF 65536-#define GENCAT_PS 16-#define GENCAT_SC 8-#define GENCAT_LL 4096-#define GENCAT_ZL 33554432-#define GENCAT_LM 1048576-#define GENCAT_PI 32768-#define GENCAT_NL 16777216-#define GENCAT_MN 2097152-#define GENCAT_LO 16384-#define MAX_UNI_CHAR 1114109-#define NUM_BLOCKS 3467-#define NUM_CONVBLOCKS 1348-#define NUM_SPACEBLOCKS 7-#define NUM_LAT1BLOCKS 63-#define NUM_RULES 207-static const struct _convrule_ rule183={GENCAT_LU, NUMCAT_LU, 1, 0, -35332, 0};-static const struct _convrule_ rule171={GENCAT_SO, NUMCAT_SO, 1, -26, 0, -26};-static const struct _convrule_ rule182={GENCAT_LL, NUMCAT_LL, 1, -7264, 0, -7264};-static const struct _convrule_ rule188={GENCAT_LU, NUMCAT_LU, 1, 0, -42315, 0};-static const struct _convrule_ rule143={GENCAT_LL, NUMCAT_LL, 1, 8, 0, 8};-static const struct _convrule_ rule127={GENCAT_LU, NUMCAT_LU, 1, 0, 38864, 0};-static const struct _convrule_ rule90={GENCAT_LL, NUMCAT_LL, 1, 42258, 0, 42258};-static const struct _convrule_ rule20={GENCAT_LL, NUMCAT_LL, 0, 0, 0, 0};-static const struct _convrule_ rule76={GENCAT_LL, NUMCAT_LL, 1, 10743, 0, 10743};-static const struct _convrule_ rule61={GENCAT_LL, NUMCAT_LL, 1, 10783, 0, 10783};-static const struct _convrule_ rule132={GENCAT_LL, NUMCAT_LL, 1, -6242, 0, -6242};-static const struct _convrule_ rule37={GENCAT_LU, NUMCAT_LU, 1, 0, 211, 0};-static const struct _convrule_ rule197={GENCAT_LL, NUMCAT_LL, 1, -928, 0, -928};-static const struct _convrule_ rule80={GENCAT_LL, NUMCAT_LL, 1, -214, 0, -214};-static const struct _convrule_ rule75={GENCAT_LL, NUMCAT_LL, 1, -211, 0, -211};-static const struct _convrule_ rule123={GENCAT_LL, NUMCAT_LL, 1, -48, 0, -48};-static const struct _convrule_ rule52={GENCAT_LU, NUMCAT_LU, 1, 0, -56, 0};-static const struct _convrule_ rule149={GENCAT_LL, NUMCAT_LL, 1, 112, 0, 112};-static const struct _convrule_ rule71={GENCAT_LL, NUMCAT_LL, 1, -207, 0, -207};-static const struct _convrule_ rule125={GENCAT_LU, NUMCAT_LU, 1, 0, 7264, 0};-static const struct _convrule_ rule204={GENCAT_LL, NUMCAT_LL, 1, -39, 0, -39};-static const struct _convrule_ rule166={GENCAT_LU, NUMCAT_LU, 1, 0, 28, 0};-static const struct _convrule_ rule173={GENCAT_LU, NUMCAT_LU, 1, 0, -3814, 0};-static const struct _convrule_ rule45={GENCAT_LU, NUMCAT_LU, 1, 0, 219, 0};-static const struct _convrule_ rule7={GENCAT_PD, NUMCAT_PD, 0, 0, 0, 0};-static const struct _convrule_ rule202={GENCAT_LL, NUMCAT_LL, 1, -40, 0, -40};-static const struct _convrule_ rule99={GENCAT_LL, NUMCAT_LL, 1, -38, 0, -38};-static const struct _convrule_ rule97={GENCAT_LU, NUMCAT_LU, 1, 0, 64, 0};-static const struct _convrule_ rule1={GENCAT_ZS, NUMCAT_ZS, 0, 0, 0, 0};-static const struct _convrule_ rule203={GENCAT_LU, NUMCAT_LU, 1, 0, 39, 0};-static const struct _convrule_ rule89={GENCAT_LL, NUMCAT_LL, 1, 42261, 0, 42261};-static const struct _convrule_ rule29={GENCAT_LU, NUMCAT_LU, 1, 0, 210, 0};-static const struct _convrule_ rule35={GENCAT_LU, NUMCAT_LU, 1, 0, 207, 0};-static const struct _convrule_ rule168={GENCAT_NL, NUMCAT_NL, 1, 0, 16, 0};-static const struct _convrule_ rule13={GENCAT_SO, NUMCAT_SO, 0, 0, 0, 0};-static const struct _convrule_ rule163={GENCAT_LU, NUMCAT_LU, 1, 0, -7517, 0};-static const struct _convrule_ rule142={GENCAT_LU, NUMCAT_LU, 1, 0, -7615, 0};-static const struct _convrule_ rule137={GENCAT_LU, NUMCAT_LU, 1, 0, -3008, 0};-static const struct _convrule_ rule100={GENCAT_LL, NUMCAT_LL, 1, -37, 0, -37};-static const struct _convrule_ rule2={GENCAT_PO, NUMCAT_PO, 0, 0, 0, 0};-static const struct _convrule_ rule69={GENCAT_LL, NUMCAT_LL, 1, 42319, 0, 42319};-static const struct _convrule_ rule56={GENCAT_LU, NUMCAT_LU, 1, 0, 10792, 0};-static const struct _convrule_ rule25={GENCAT_LL, NUMCAT_LL, 1, -232, 0, -232};-static const struct _convrule_ rule43={GENCAT_LU, NUMCAT_LU, 1, 0, 218, 0};-static const struct _convrule_ rule179={GENCAT_LU, NUMCAT_LU, 1, 0, -10783, 0};-static const struct _convrule_ rule147={GENCAT_LL, NUMCAT_LL, 1, 100, 0, 100};-static const struct _convrule_ rule98={GENCAT_LU, NUMCAT_LU, 1, 0, 63, 0};-static const struct _convrule_ rule92={GENCAT_MN, NUMCAT_MN, 0, 0, 0, 0};-static const struct _convrule_ rule12={GENCAT_LL, NUMCAT_LL, 1, -32, 0, -32};-static const struct _convrule_ rule95={GENCAT_LU, NUMCAT_LU, 1, 0, 38, 0};-static const struct _convrule_ rule140={GENCAT_LL, NUMCAT_LL, 1, 35384, 0, 35384};-static const struct _convrule_ rule101={GENCAT_LL, NUMCAT_LL, 1, -31, 0, -31};-static const struct _convrule_ rule206={GENCAT_LL, NUMCAT_LL, 1, -34, 0, -34};-static const struct _convrule_ rule107={GENCAT_LU, NUMCAT_LU, 0, 0, 0, 0};-static const struct _convrule_ rule11={GENCAT_PC, NUMCAT_PC, 0, 0, 0, 0};-static const struct _convrule_ rule192={GENCAT_LU, NUMCAT_LU, 1, 0, -42261, 0};-static const struct _convrule_ rule190={GENCAT_LU, NUMCAT_LU, 1, 0, -42258, 0};-static const struct _convrule_ rule158={GENCAT_LU, NUMCAT_LU, 1, 0, -112, 0};-static const struct _convrule_ rule15={GENCAT_PI, NUMCAT_PI, 0, 0, 0, 0};-static const struct _convrule_ rule146={GENCAT_LL, NUMCAT_LL, 1, 86, 0, 86};-static const struct _convrule_ rule124={GENCAT_MC, NUMCAT_MC, 0, 0, 0, 0};-static const struct _convrule_ rule139={GENCAT_LL, NUMCAT_LL, 1, 3814, 0, 3814};-static const struct _convrule_ rule44={GENCAT_LU, NUMCAT_LU, 1, 0, 217, 0};-static const struct _convrule_ rule167={GENCAT_LL, NUMCAT_LL, 1, -28, 0, -28};-static const struct _convrule_ rule200={GENCAT_CO, NUMCAT_CO, 0, 0, 0, 0};-static const struct _convrule_ rule196={GENCAT_LU, NUMCAT_LU, 1, 0, -35384, 0};-static const struct _convrule_ rule116={GENCAT_LL, NUMCAT_LL, 1, -96, 0, -96};-static const struct _convrule_ rule185={GENCAT_LL, NUMCAT_LL, 1, 48, 0, 48};-static const struct _convrule_ rule51={GENCAT_LU, NUMCAT_LU, 1, 0, -97, 0};-static const struct _convrule_ rule39={GENCAT_LL, NUMCAT_LL, 1, 163, 0, 163};-static const struct _convrule_ rule201={GENCAT_LU, NUMCAT_LU, 1, 0, 40, 0};-static const struct _convrule_ rule128={GENCAT_NL, NUMCAT_NL, 0, 0, 0, 0};-static const struct _convrule_ rule126={GENCAT_LL, NUMCAT_LL, 1, 3008, 0, 0};-static const struct _convrule_ rule96={GENCAT_LU, NUMCAT_LU, 1, 0, 37, 0};-static const struct _convrule_ rule82={GENCAT_LL, NUMCAT_LL, 1, -218, 0, -218};-static const struct _convrule_ rule120={GENCAT_LU, NUMCAT_LU, 1, 0, 15, 0};-static const struct _convrule_ rule67={GENCAT_LL, NUMCAT_LL, 1, -202, 0, -202};-static const struct _convrule_ rule66={GENCAT_LL, NUMCAT_LL, 1, -205, 0, -205};-static const struct _convrule_ rule47={GENCAT_LU, NUMCAT_LU, 1, 0, 2, 1};-static const struct _convrule_ rule136={GENCAT_LL, NUMCAT_LL, 1, 35266, 0, 35266};-static const struct _convrule_ rule83={GENCAT_LL, NUMCAT_LL, 1, 42307, 0, 42307};-static const struct _convrule_ rule30={GENCAT_LU, NUMCAT_LU, 1, 0, 206, 0};-static const struct _convrule_ rule111={GENCAT_LL, NUMCAT_LL, 1, -86, 0, -86};-static const struct _convrule_ rule4={GENCAT_PS, NUMCAT_PS, 0, 0, 0, 0};-static const struct _convrule_ rule3={GENCAT_SC, NUMCAT_SC, 0, 0, 0, 0};-static const struct _convrule_ rule164={GENCAT_LU, NUMCAT_LU, 1, 0, -8383, 0};-static const struct _convrule_ rule122={GENCAT_LU, NUMCAT_LU, 1, 0, 48, 0};-static const struct _convrule_ rule14={GENCAT_LO, NUMCAT_LO, 0, 0, 0, 0};-static const struct _convrule_ rule18={GENCAT_LL, NUMCAT_LL, 1, 743, 0, 743};-static const struct _convrule_ rule161={GENCAT_ZL, NUMCAT_ZL, 0, 0, 0, 0};-static const struct _convrule_ rule156={GENCAT_LU, NUMCAT_LU, 1, 0, -86, 0};-static const struct _convrule_ rule186={GENCAT_LU, NUMCAT_LU, 1, 0, -42308, 0};-static const struct _convrule_ rule176={GENCAT_LL, NUMCAT_LL, 1, -10792, 0, -10792};-static const struct _convrule_ rule180={GENCAT_LU, NUMCAT_LU, 1, 0, -10782, 0};-static const struct _convrule_ rule198={GENCAT_LL, NUMCAT_LL, 1, -38864, 0, -38864};-static const struct _convrule_ rule153={GENCAT_LU, NUMCAT_LU, 1, 0, -74, 0};-static const struct _convrule_ rule24={GENCAT_LU, NUMCAT_LU, 1, 0, -199, 0};-static const struct _convrule_ rule157={GENCAT_LU, NUMCAT_LU, 1, 0, -100, 0};-static const struct _convrule_ rule138={GENCAT_LL, NUMCAT_LL, 1, 35332, 0, 35332};-static const struct _convrule_ rule155={GENCAT_LL, NUMCAT_LL, 1, -7205, 0, -7205};-static const struct _convrule_ rule152={GENCAT_LL, NUMCAT_LL, 1, 9, 0, 9};-static const struct _convrule_ rule27={GENCAT_LL, NUMCAT_LL, 1, -300, 0, -300};-static const struct _convrule_ rule187={GENCAT_LU, NUMCAT_LU, 1, 0, -42319, 0};-static const struct _convrule_ rule31={GENCAT_LU, NUMCAT_LU, 1, 0, 205, 0};-static const struct _convrule_ rule59={GENCAT_LU, NUMCAT_LU, 1, 0, 69, 0};-static const struct _convrule_ rule6={GENCAT_SM, NUMCAT_SM, 0, 0, 0, 0};-static const struct _convrule_ rule121={GENCAT_LL, NUMCAT_LL, 1, -15, 0, -15};-static const struct _convrule_ rule112={GENCAT_LL, NUMCAT_LL, 1, -80, 0, -80};-static const struct _convrule_ rule191={GENCAT_LU, NUMCAT_LU, 1, 0, -42282, 0};-static const struct _convrule_ rule133={GENCAT_LL, NUMCAT_LL, 1, -6243, 0, -6243};-static const struct _convrule_ rule130={GENCAT_LL, NUMCAT_LL, 1, -6253, 0, -6253};-static const struct _convrule_ rule165={GENCAT_LU, NUMCAT_LU, 1, 0, -8262, 0};-static const struct _convrule_ rule144={GENCAT_LU, NUMCAT_LU, 1, 0, -8, 0};-static const struct _convrule_ rule26={GENCAT_LU, NUMCAT_LU, 1, 0, -121, 0};-static const struct _convrule_ rule0={GENCAT_CC, NUMCAT_CC, 0, 0, 0, 0};-static const struct _convrule_ rule113={GENCAT_LL, NUMCAT_LL, 1, 7, 0, 7};-static const struct _convrule_ rule93={GENCAT_MN, NUMCAT_MN, 1, 84, 0, 84};-static const struct _convrule_ rule78={GENCAT_LL, NUMCAT_LL, 1, 10749, 0, 10749};-static const struct _convrule_ rule77={GENCAT_LL, NUMCAT_LL, 1, 42305, 0, 42305};-static const struct _convrule_ rule70={GENCAT_LL, NUMCAT_LL, 1, 42315, 0, 42315};-static const struct _convrule_ rule50={GENCAT_LL, NUMCAT_LL, 1, -79, 0, -79};-static const struct _convrule_ rule60={GENCAT_LU, NUMCAT_LU, 1, 0, 71, 0};-static const struct _convrule_ rule22={GENCAT_LU, NUMCAT_LU, 1, 0, 1, 0};-static const struct _convrule_ rule49={GENCAT_LL, NUMCAT_LL, 1, -2, 0, -1};-static const struct _convrule_ rule94={GENCAT_LU, NUMCAT_LU, 1, 0, 116, 0};-static const struct _convrule_ rule84={GENCAT_LL, NUMCAT_LL, 1, 42282, 0, 42282};-static const struct _convrule_ rule169={GENCAT_NL, NUMCAT_NL, 1, -16, 0, -16};-static const struct _convrule_ rule104={GENCAT_LU, NUMCAT_LU, 1, 0, 8, 0};-static const struct _convrule_ rule23={GENCAT_LL, NUMCAT_LL, 1, -1, 0, -1};-static const struct _convrule_ rule88={GENCAT_LL, NUMCAT_LL, 1, -219, 0, -219};-static const struct _convrule_ rule79={GENCAT_LL, NUMCAT_LL, 1, -213, 0, -213};-static const struct _convrule_ rule64={GENCAT_LL, NUMCAT_LL, 1, -210, 0, -210};-static const struct _convrule_ rule177={GENCAT_LU, NUMCAT_LU, 1, 0, -10780, 0};-static const struct _convrule_ rule87={GENCAT_LL, NUMCAT_LL, 1, -71, 0, -71};-static const struct _convrule_ rule85={GENCAT_LL, NUMCAT_LL, 1, -69, 0, -69};-static const struct _convrule_ rule32={GENCAT_LU, NUMCAT_LU, 1, 0, 79, 0};-static const struct _convrule_ rule195={GENCAT_LU, NUMCAT_LU, 1, 0, -42307, 0};-static const struct _convrule_ rule117={GENCAT_LU, NUMCAT_LU, 1, 0, -7, 0};-static const struct _convrule_ rule74={GENCAT_LL, NUMCAT_LL, 1, -209, 0, -209};-static const struct _convrule_ rule199={GENCAT_CS, NUMCAT_CS, 0, 0, 0, 0};-static const struct _convrule_ rule154={GENCAT_LT, NUMCAT_LT, 1, 0, -9, 0};-static const struct _convrule_ rule57={GENCAT_LL, NUMCAT_LL, 1, 10815, 0, 10815};-static const struct _convrule_ rule72={GENCAT_LL, NUMCAT_LL, 1, 42280, 0, 42280};-static const struct _convrule_ rule34={GENCAT_LU, NUMCAT_LU, 1, 0, 203, 0};-static const struct _convrule_ rule194={GENCAT_LU, NUMCAT_LU, 1, 0, -48, 0};-static const struct _convrule_ rule63={GENCAT_LL, NUMCAT_LL, 1, 10782, 0, 10782};-static const struct _convrule_ rule184={GENCAT_LU, NUMCAT_LU, 1, 0, -42280, 0};-static const struct _convrule_ rule159={GENCAT_LU, NUMCAT_LU, 1, 0, -128, 0};-static const struct _convrule_ rule102={GENCAT_LL, NUMCAT_LL, 1, -64, 0, -64};-static const struct _convrule_ rule17={GENCAT_NO, NUMCAT_NO, 0, 0, 0, 0};-static const struct _convrule_ rule91={GENCAT_LM, NUMCAT_LM, 0, 0, 0, 0};-static const struct _convrule_ rule46={GENCAT_LL, NUMCAT_LL, 1, 56, 0, 56};-static const struct _convrule_ rule145={GENCAT_LL, NUMCAT_LL, 1, 74, 0, 74};-static const struct _convrule_ rule42={GENCAT_LU, NUMCAT_LU, 1, 0, 214, 0};-static const struct _convrule_ rule162={GENCAT_ZP, NUMCAT_ZP, 0, 0, 0, 0};-static const struct _convrule_ rule103={GENCAT_LL, NUMCAT_LL, 1, -63, 0, -63};-static const struct _convrule_ rule36={GENCAT_LL, NUMCAT_LL, 1, 97, 0, 97};-static const struct _convrule_ rule151={GENCAT_LT, NUMCAT_LT, 1, 0, -8, 0};-static const struct _convrule_ rule148={GENCAT_LL, NUMCAT_LL, 1, 128, 0, 128};-static const struct _convrule_ rule81={GENCAT_LL, NUMCAT_LL, 1, 10727, 0, 10727};-static const struct _convrule_ rule62={GENCAT_LL, NUMCAT_LL, 1, 10780, 0, 10780};-static const struct _convrule_ rule41={GENCAT_LL, NUMCAT_LL, 1, 130, 0, 130};-static const struct _convrule_ rule205={GENCAT_LU, NUMCAT_LU, 1, 0, 34, 0};-static const struct _convrule_ rule134={GENCAT_LL, NUMCAT_LL, 1, -6236, 0, -6236};-static const struct _convrule_ rule68={GENCAT_LL, NUMCAT_LL, 1, -203, 0, -203};-static const struct _convrule_ rule65={GENCAT_LL, NUMCAT_LL, 1, -206, 0, -206};-static const struct _convrule_ rule48={GENCAT_LT, NUMCAT_LT, 1, -1, 1, 0};-static const struct _convrule_ rule19={GENCAT_PF, NUMCAT_PF, 0, 0, 0, 0};-static const struct _convrule_ rule33={GENCAT_LU, NUMCAT_LU, 1, 0, 202, 0};-static const struct _convrule_ rule105={GENCAT_LL, NUMCAT_LL, 1, -62, 0, -62};-static const struct _convrule_ rule8={GENCAT_ND, NUMCAT_ND, 0, 0, 0, 0};-static const struct _convrule_ rule193={GENCAT_LU, NUMCAT_LU, 1, 0, 928, 0};-static const struct _convrule_ rule53={GENCAT_LU, NUMCAT_LU, 1, 0, -130, 0};-static const struct _convrule_ rule28={GENCAT_LL, NUMCAT_LL, 1, 195, 0, 195};-static const struct _convrule_ rule172={GENCAT_LU, NUMCAT_LU, 1, 0, -10743, 0};-static const struct _convrule_ rule141={GENCAT_LL, NUMCAT_LL, 1, -59, 0, -59};-static const struct _convrule_ rule115={GENCAT_LU, NUMCAT_LU, 1, 0, -60, 0};-static const struct _convrule_ rule110={GENCAT_LL, NUMCAT_LL, 1, -8, 0, -8};-static const struct _convrule_ rule73={GENCAT_LL, NUMCAT_LL, 1, 42308, 0, 42308};-static const struct _convrule_ rule40={GENCAT_LU, NUMCAT_LU, 1, 0, 213, 0};-static const struct _convrule_ rule150={GENCAT_LL, NUMCAT_LL, 1, 126, 0, 126};-static const struct _convrule_ rule131={GENCAT_LL, NUMCAT_LL, 1, -6244, 0, -6244};-static const struct _convrule_ rule129={GENCAT_LL, NUMCAT_LL, 1, -6254, 0, -6254};-static const struct _convrule_ rule118={GENCAT_LU, NUMCAT_LU, 1, 0, 80, 0};-static const struct _convrule_ rule55={GENCAT_LU, NUMCAT_LU, 1, 0, -163, 0};-static const struct _convrule_ rule189={GENCAT_LU, NUMCAT_LU, 1, 0, -42305, 0};-static const struct _convrule_ rule175={GENCAT_LL, NUMCAT_LL, 1, -10795, 0, -10795};-static const struct _convrule_ rule58={GENCAT_LU, NUMCAT_LU, 1, 0, -195, 0};-static const struct _convrule_ rule54={GENCAT_LU, NUMCAT_LU, 1, 0, 10795, 0};-static const struct _convrule_ rule135={GENCAT_LL, NUMCAT_LL, 1, -6181, 0, -6181};-static const struct _convrule_ rule109={GENCAT_LL, NUMCAT_LL, 1, -54, 0, -54};-static const struct _convrule_ rule160={GENCAT_LU, NUMCAT_LU, 1, 0, -126, 0};-static const struct _convrule_ rule106={GENCAT_LL, NUMCAT_LL, 1, -57, 0, -57};-static const struct _convrule_ rule21={GENCAT_LL, NUMCAT_LL, 1, 121, 0, 121};-static const struct _convrule_ rule170={GENCAT_SO, NUMCAT_SO, 1, 0, 26, 0};-static const struct _convrule_ rule86={GENCAT_LL, NUMCAT_LL, 1, -217, 0, -217};-static const struct _convrule_ rule16={GENCAT_CF, NUMCAT_CF, 0, 0, 0, 0};-static const struct _convrule_ rule114={GENCAT_LL, NUMCAT_LL, 1, -116, 0, -116};-static const struct _convrule_ rule38={GENCAT_LU, NUMCAT_LU, 1, 0, 209, 0};-static const struct _convrule_ rule10={GENCAT_SK, NUMCAT_SK, 0, 0, 0, 0};-static const struct _convrule_ rule181={GENCAT_LU, NUMCAT_LU, 1, 0, -10815, 0};-static const struct _convrule_ rule5={GENCAT_PE, NUMCAT_PE, 0, 0, 0, 0};-static const struct _convrule_ rule178={GENCAT_LU, NUMCAT_LU, 1, 0, -10749, 0};-static const struct _convrule_ rule119={GENCAT_ME, NUMCAT_ME, 0, 0, 0, 0};-static const struct _convrule_ rule108={GENCAT_LL, NUMCAT_LL, 1, -47, 0, -47};-static const struct _convrule_ rule174={GENCAT_LU, NUMCAT_LU, 1, 0, -10727, 0};-static const struct _convrule_ rule9={GENCAT_LU, NUMCAT_LU, 1, 0, 32, 0};-static const struct _charblock_ allchars[]={-	{0, 32, &rule0},-	{32, 1, &rule1},-	{33, 3, &rule2},-	{36, 1, &rule3},-	{37, 3, &rule2},-	{40, 1, &rule4},-	{41, 1, &rule5},-	{42, 1, &rule2},-	{43, 1, &rule6},-	{44, 1, &rule2},-	{45, 1, &rule7},-	{46, 2, &rule2},-	{48, 10, &rule8},-	{58, 2, &rule2},-	{60, 3, &rule6},-	{63, 2, &rule2},-	{65, 26, &rule9},-	{91, 1, &rule4},-	{92, 1, &rule2},-	{93, 1, &rule5},-	{94, 1, &rule10},-	{95, 1, &rule11},-	{96, 1, &rule10},-	{97, 26, &rule12},-	{123, 1, &rule4},-	{124, 1, &rule6},-	{125, 1, &rule5},-	{126, 1, &rule6},-	{127, 33, &rule0},-	{160, 1, &rule1},-	{161, 1, &rule2},-	{162, 4, &rule3},-	{166, 1, &rule13},-	{167, 1, &rule2},-	{168, 1, &rule10},-	{169, 1, &rule13},-	{170, 1, &rule14},-	{171, 1, &rule15},-	{172, 1, &rule6},-	{173, 1, &rule16},-	{174, 1, &rule13},-	{175, 1, &rule10},-	{176, 1, &rule13},-	{177, 1, &rule6},-	{178, 2, &rule17},-	{180, 1, &rule10},-	{181, 1, &rule18},-	{182, 2, &rule2},-	{184, 1, &rule10},-	{185, 1, &rule17},-	{186, 1, &rule14},-	{187, 1, &rule19},-	{188, 3, &rule17},-	{191, 1, &rule2},-	{192, 23, &rule9},-	{215, 1, &rule6},-	{216, 7, &rule9},-	{223, 1, &rule20},-	{224, 23, &rule12},-	{247, 1, &rule6},-	{248, 7, &rule12},-	{255, 1, &rule21},-	{256, 1, &rule22},-	{257, 1, &rule23},-	{258, 1, &rule22},-	{259, 1, &rule23},-	{260, 1, &rule22},-	{261, 1, &rule23},-	{262, 1, &rule22},-	{263, 1, &rule23},-	{264, 1, &rule22},-	{265, 1, &rule23},-	{266, 1, &rule22},-	{267, 1, &rule23},-	{268, 1, &rule22},-	{269, 1, &rule23},-	{270, 1, &rule22},-	{271, 1, &rule23},-	{272, 1, &rule22},-	{273, 1, &rule23},-	{274, 1, &rule22},-	{275, 1, &rule23},-	{276, 1, &rule22},-	{277, 1, &rule23},-	{278, 1, &rule22},-	{279, 1, &rule23},-	{280, 1, &rule22},-	{281, 1, &rule23},-	{282, 1, &rule22},-	{283, 1, &rule23},-	{284, 1, &rule22},-	{285, 1, &rule23},-	{286, 1, &rule22},-	{287, 1, &rule23},-	{288, 1, &rule22},-	{289, 1, &rule23},-	{290, 1, &rule22},-	{291, 1, &rule23},-	{292, 1, &rule22},-	{293, 1, &rule23},-	{294, 1, &rule22},-	{295, 1, &rule23},-	{296, 1, &rule22},-	{297, 1, &rule23},-	{298, 1, &rule22},-	{299, 1, &rule23},-	{300, 1, &rule22},-	{301, 1, &rule23},-	{302, 1, &rule22},-	{303, 1, &rule23},-	{304, 1, &rule24},-	{305, 1, &rule25},-	{306, 1, &rule22},-	{307, 1, &rule23},-	{308, 1, &rule22},-	{309, 1, &rule23},-	{310, 1, &rule22},-	{311, 1, &rule23},-	{312, 1, &rule20},-	{313, 1, &rule22},-	{314, 1, &rule23},-	{315, 1, &rule22},-	{316, 1, &rule23},-	{317, 1, &rule22},-	{318, 1, &rule23},-	{319, 1, &rule22},-	{320, 1, &rule23},-	{321, 1, &rule22},-	{322, 1, &rule23},-	{323, 1, &rule22},-	{324, 1, &rule23},-	{325, 1, &rule22},-	{326, 1, &rule23},-	{327, 1, &rule22},-	{328, 1, &rule23},-	{329, 1, &rule20},-	{330, 1, &rule22},-	{331, 1, &rule23},-	{332, 1, &rule22},-	{333, 1, &rule23},-	{334, 1, &rule22},-	{335, 1, &rule23},-	{336, 1, &rule22},-	{337, 1, &rule23},-	{338, 1, &rule22},-	{339, 1, &rule23},-	{340, 1, &rule22},-	{341, 1, &rule23},-	{342, 1, &rule22},-	{343, 1, &rule23},-	{344, 1, &rule22},-	{345, 1, &rule23},-	{346, 1, &rule22},-	{347, 1, &rule23},-	{348, 1, &rule22},-	{349, 1, &rule23},-	{350, 1, &rule22},-	{351, 1, &rule23},-	{352, 1, &rule22},-	{353, 1, &rule23},-	{354, 1, &rule22},-	{355, 1, &rule23},-	{356, 1, &rule22},-	{357, 1, &rule23},-	{358, 1, &rule22},-	{359, 1, &rule23},-	{360, 1, &rule22},-	{361, 1, &rule23},-	{362, 1, &rule22},-	{363, 1, &rule23},-	{364, 1, &rule22},-	{365, 1, &rule23},-	{366, 1, &rule22},-	{367, 1, &rule23},-	{368, 1, &rule22},-	{369, 1, &rule23},-	{370, 1, &rule22},-	{371, 1, &rule23},-	{372, 1, &rule22},-	{373, 1, &rule23},-	{374, 1, &rule22},-	{375, 1, &rule23},-	{376, 1, &rule26},-	{377, 1, &rule22},-	{378, 1, &rule23},-	{379, 1, &rule22},-	{380, 1, &rule23},-	{381, 1, &rule22},-	{382, 1, &rule23},-	{383, 1, &rule27},-	{384, 1, &rule28},-	{385, 1, &rule29},-	{386, 1, &rule22},-	{387, 1, &rule23},-	{388, 1, &rule22},-	{389, 1, &rule23},-	{390, 1, &rule30},-	{391, 1, &rule22},-	{392, 1, &rule23},-	{393, 2, &rule31},-	{395, 1, &rule22},-	{396, 1, &rule23},-	{397, 1, &rule20},-	{398, 1, &rule32},-	{399, 1, &rule33},-	{400, 1, &rule34},-	{401, 1, &rule22},-	{402, 1, &rule23},-	{403, 1, &rule31},-	{404, 1, &rule35},-	{405, 1, &rule36},-	{406, 1, &rule37},-	{407, 1, &rule38},-	{408, 1, &rule22},-	{409, 1, &rule23},-	{410, 1, &rule39},-	{411, 1, &rule20},-	{412, 1, &rule37},-	{413, 1, &rule40},-	{414, 1, &rule41},-	{415, 1, &rule42},-	{416, 1, &rule22},-	{417, 1, &rule23},-	{418, 1, &rule22},-	{419, 1, &rule23},-	{420, 1, &rule22},-	{421, 1, &rule23},-	{422, 1, &rule43},-	{423, 1, &rule22},-	{424, 1, &rule23},-	{425, 1, &rule43},-	{426, 2, &rule20},-	{428, 1, &rule22},-	{429, 1, &rule23},-	{430, 1, &rule43},-	{431, 1, &rule22},-	{432, 1, &rule23},-	{433, 2, &rule44},-	{435, 1, &rule22},-	{436, 1, &rule23},-	{437, 1, &rule22},-	{438, 1, &rule23},-	{439, 1, &rule45},-	{440, 1, &rule22},-	{441, 1, &rule23},-	{442, 1, &rule20},-	{443, 1, &rule14},-	{444, 1, &rule22},-	{445, 1, &rule23},-	{446, 1, &rule20},-	{447, 1, &rule46},-	{448, 4, &rule14},-	{452, 1, &rule47},-	{453, 1, &rule48},-	{454, 1, &rule49},-	{455, 1, &rule47},-	{456, 1, &rule48},-	{457, 1, &rule49},-	{458, 1, &rule47},-	{459, 1, &rule48},-	{460, 1, &rule49},-	{461, 1, &rule22},-	{462, 1, &rule23},-	{463, 1, &rule22},-	{464, 1, &rule23},-	{465, 1, &rule22},-	{466, 1, &rule23},-	{467, 1, &rule22},-	{468, 1, &rule23},-	{469, 1, &rule22},-	{470, 1, &rule23},-	{471, 1, &rule22},-	{472, 1, &rule23},-	{473, 1, &rule22},-	{474, 1, &rule23},-	{475, 1, &rule22},-	{476, 1, &rule23},-	{477, 1, &rule50},-	{478, 1, &rule22},-	{479, 1, &rule23},-	{480, 1, &rule22},-	{481, 1, &rule23},-	{482, 1, &rule22},-	{483, 1, &rule23},-	{484, 1, &rule22},-	{485, 1, &rule23},-	{486, 1, &rule22},-	{487, 1, &rule23},-	{488, 1, &rule22},-	{489, 1, &rule23},-	{490, 1, &rule22},-	{491, 1, &rule23},-	{492, 1, &rule22},-	{493, 1, &rule23},-	{494, 1, &rule22},-	{495, 1, &rule23},-	{496, 1, &rule20},-	{497, 1, &rule47},-	{498, 1, &rule48},-	{499, 1, &rule49},-	{500, 1, &rule22},-	{501, 1, &rule23},-	{502, 1, &rule51},-	{503, 1, &rule52},-	{504, 1, &rule22},-	{505, 1, &rule23},-	{506, 1, &rule22},-	{507, 1, &rule23},-	{508, 1, &rule22},-	{509, 1, &rule23},-	{510, 1, &rule22},-	{511, 1, &rule23},-	{512, 1, &rule22},-	{513, 1, &rule23},-	{514, 1, &rule22},-	{515, 1, &rule23},-	{516, 1, &rule22},-	{517, 1, &rule23},-	{518, 1, &rule22},-	{519, 1, &rule23},-	{520, 1, &rule22},-	{521, 1, &rule23},-	{522, 1, &rule22},-	{523, 1, &rule23},-	{524, 1, &rule22},-	{525, 1, &rule23},-	{526, 1, &rule22},-	{527, 1, &rule23},-	{528, 1, &rule22},-	{529, 1, &rule23},-	{530, 1, &rule22},-	{531, 1, &rule23},-	{532, 1, &rule22},-	{533, 1, &rule23},-	{534, 1, &rule22},-	{535, 1, &rule23},-	{536, 1, &rule22},-	{537, 1, &rule23},-	{538, 1, &rule22},-	{539, 1, &rule23},-	{540, 1, &rule22},-	{541, 1, &rule23},-	{542, 1, &rule22},-	{543, 1, &rule23},-	{544, 1, &rule53},-	{545, 1, &rule20},-	{546, 1, &rule22},-	{547, 1, &rule23},-	{548, 1, &rule22},-	{549, 1, &rule23},-	{550, 1, &rule22},-	{551, 1, &rule23},-	{552, 1, &rule22},-	{553, 1, &rule23},-	{554, 1, &rule22},-	{555, 1, &rule23},-	{556, 1, &rule22},-	{557, 1, &rule23},-	{558, 1, &rule22},-	{559, 1, &rule23},-	{560, 1, &rule22},-	{561, 1, &rule23},-	{562, 1, &rule22},-	{563, 1, &rule23},-	{564, 6, &rule20},-	{570, 1, &rule54},-	{571, 1, &rule22},-	{572, 1, &rule23},-	{573, 1, &rule55},-	{574, 1, &rule56},-	{575, 2, &rule57},-	{577, 1, &rule22},-	{578, 1, &rule23},-	{579, 1, &rule58},-	{580, 1, &rule59},-	{581, 1, &rule60},-	{582, 1, &rule22},-	{583, 1, &rule23},-	{584, 1, &rule22},-	{585, 1, &rule23},-	{586, 1, &rule22},-	{587, 1, &rule23},-	{588, 1, &rule22},-	{589, 1, &rule23},-	{590, 1, &rule22},-	{591, 1, &rule23},-	{592, 1, &rule61},-	{593, 1, &rule62},-	{594, 1, &rule63},-	{595, 1, &rule64},-	{596, 1, &rule65},-	{597, 1, &rule20},-	{598, 2, &rule66},-	{600, 1, &rule20},-	{601, 1, &rule67},-	{602, 1, &rule20},-	{603, 1, &rule68},-	{604, 1, &rule69},-	{605, 3, &rule20},-	{608, 1, &rule66},-	{609, 1, &rule70},-	{610, 1, &rule20},-	{611, 1, &rule71},-	{612, 1, &rule20},-	{613, 1, &rule72},-	{614, 1, &rule73},-	{615, 1, &rule20},-	{616, 1, &rule74},-	{617, 1, &rule75},-	{618, 1, &rule73},-	{619, 1, &rule76},-	{620, 1, &rule77},-	{621, 2, &rule20},-	{623, 1, &rule75},-	{624, 1, &rule20},-	{625, 1, &rule78},-	{626, 1, &rule79},-	{627, 2, &rule20},-	{629, 1, &rule80},-	{630, 7, &rule20},-	{637, 1, &rule81},-	{638, 2, &rule20},-	{640, 1, &rule82},-	{641, 1, &rule20},-	{642, 1, &rule83},-	{643, 1, &rule82},-	{644, 3, &rule20},-	{647, 1, &rule84},-	{648, 1, &rule82},-	{649, 1, &rule85},-	{650, 2, &rule86},-	{652, 1, &rule87},-	{653, 5, &rule20},-	{658, 1, &rule88},-	{659, 1, &rule20},-	{660, 1, &rule14},-	{661, 8, &rule20},-	{669, 1, &rule89},-	{670, 1, &rule90},-	{671, 17, &rule20},-	{688, 18, &rule91},-	{706, 4, &rule10},-	{710, 12, &rule91},-	{722, 14, &rule10},-	{736, 5, &rule91},-	{741, 7, &rule10},-	{748, 1, &rule91},-	{749, 1, &rule10},-	{750, 1, &rule91},-	{751, 17, &rule10},-	{768, 69, &rule92},-	{837, 1, &rule93},-	{838, 42, &rule92},-	{880, 1, &rule22},-	{881, 1, &rule23},-	{882, 1, &rule22},-	{883, 1, &rule23},-	{884, 1, &rule91},-	{885, 1, &rule10},-	{886, 1, &rule22},-	{887, 1, &rule23},-	{890, 1, &rule91},-	{891, 3, &rule41},-	{894, 1, &rule2},-	{895, 1, &rule94},-	{900, 2, &rule10},-	{902, 1, &rule95},-	{903, 1, &rule2},-	{904, 3, &rule96},-	{908, 1, &rule97},-	{910, 2, &rule98},-	{912, 1, &rule20},-	{913, 17, &rule9},-	{931, 9, &rule9},-	{940, 1, &rule99},-	{941, 3, &rule100},-	{944, 1, &rule20},-	{945, 17, &rule12},-	{962, 1, &rule101},-	{963, 9, &rule12},-	{972, 1, &rule102},-	{973, 2, &rule103},-	{975, 1, &rule104},-	{976, 1, &rule105},-	{977, 1, &rule106},-	{978, 3, &rule107},-	{981, 1, &rule108},-	{982, 1, &rule109},-	{983, 1, &rule110},-	{984, 1, &rule22},-	{985, 1, &rule23},-	{986, 1, &rule22},-	{987, 1, &rule23},-	{988, 1, &rule22},-	{989, 1, &rule23},-	{990, 1, &rule22},-	{991, 1, &rule23},-	{992, 1, &rule22},-	{993, 1, &rule23},-	{994, 1, &rule22},-	{995, 1, &rule23},-	{996, 1, &rule22},-	{997, 1, &rule23},-	{998, 1, &rule22},-	{999, 1, &rule23},-	{1000, 1, &rule22},-	{1001, 1, &rule23},-	{1002, 1, &rule22},-	{1003, 1, &rule23},-	{1004, 1, &rule22},-	{1005, 1, &rule23},-	{1006, 1, &rule22},-	{1007, 1, &rule23},-	{1008, 1, &rule111},-	{1009, 1, &rule112},-	{1010, 1, &rule113},-	{1011, 1, &rule114},-	{1012, 1, &rule115},-	{1013, 1, &rule116},-	{1014, 1, &rule6},-	{1015, 1, &rule22},-	{1016, 1, &rule23},-	{1017, 1, &rule117},-	{1018, 1, &rule22},-	{1019, 1, &rule23},-	{1020, 1, &rule20},-	{1021, 3, &rule53},-	{1024, 16, &rule118},-	{1040, 32, &rule9},-	{1072, 32, &rule12},-	{1104, 16, &rule112},-	{1120, 1, &rule22},-	{1121, 1, &rule23},-	{1122, 1, &rule22},-	{1123, 1, &rule23},-	{1124, 1, &rule22},-	{1125, 1, &rule23},-	{1126, 1, &rule22},-	{1127, 1, &rule23},-	{1128, 1, &rule22},-	{1129, 1, &rule23},-	{1130, 1, &rule22},-	{1131, 1, &rule23},-	{1132, 1, &rule22},-	{1133, 1, &rule23},-	{1134, 1, &rule22},-	{1135, 1, &rule23},-	{1136, 1, &rule22},-	{1137, 1, &rule23},-	{1138, 1, &rule22},-	{1139, 1, &rule23},-	{1140, 1, &rule22},-	{1141, 1, &rule23},-	{1142, 1, &rule22},-	{1143, 1, &rule23},-	{1144, 1, &rule22},-	{1145, 1, &rule23},-	{1146, 1, &rule22},-	{1147, 1, &rule23},-	{1148, 1, &rule22},-	{1149, 1, &rule23},-	{1150, 1, &rule22},-	{1151, 1, &rule23},-	{1152, 1, &rule22},-	{1153, 1, &rule23},-	{1154, 1, &rule13},-	{1155, 5, &rule92},-	{1160, 2, &rule119},-	{1162, 1, &rule22},-	{1163, 1, &rule23},-	{1164, 1, &rule22},-	{1165, 1, &rule23},-	{1166, 1, &rule22},-	{1167, 1, &rule23},-	{1168, 1, &rule22},-	{1169, 1, &rule23},-	{1170, 1, &rule22},-	{1171, 1, &rule23},-	{1172, 1, &rule22},-	{1173, 1, &rule23},-	{1174, 1, &rule22},-	{1175, 1, &rule23},-	{1176, 1, &rule22},-	{1177, 1, &rule23},-	{1178, 1, &rule22},-	{1179, 1, &rule23},-	{1180, 1, &rule22},-	{1181, 1, &rule23},-	{1182, 1, &rule22},-	{1183, 1, &rule23},-	{1184, 1, &rule22},-	{1185, 1, &rule23},-	{1186, 1, &rule22},-	{1187, 1, &rule23},-	{1188, 1, &rule22},-	{1189, 1, &rule23},-	{1190, 1, &rule22},-	{1191, 1, &rule23},-	{1192, 1, &rule22},-	{1193, 1, &rule23},-	{1194, 1, &rule22},-	{1195, 1, &rule23},-	{1196, 1, &rule22},-	{1197, 1, &rule23},-	{1198, 1, &rule22},-	{1199, 1, &rule23},-	{1200, 1, &rule22},-	{1201, 1, &rule23},-	{1202, 1, &rule22},-	{1203, 1, &rule23},-	{1204, 1, &rule22},-	{1205, 1, &rule23},-	{1206, 1, &rule22},-	{1207, 1, &rule23},-	{1208, 1, &rule22},-	{1209, 1, &rule23},-	{1210, 1, &rule22},-	{1211, 1, &rule23},-	{1212, 1, &rule22},-	{1213, 1, &rule23},-	{1214, 1, &rule22},-	{1215, 1, &rule23},-	{1216, 1, &rule120},-	{1217, 1, &rule22},-	{1218, 1, &rule23},-	{1219, 1, &rule22},-	{1220, 1, &rule23},-	{1221, 1, &rule22},-	{1222, 1, &rule23},-	{1223, 1, &rule22},-	{1224, 1, &rule23},-	{1225, 1, &rule22},-	{1226, 1, &rule23},-	{1227, 1, &rule22},-	{1228, 1, &rule23},-	{1229, 1, &rule22},-	{1230, 1, &rule23},-	{1231, 1, &rule121},-	{1232, 1, &rule22},-	{1233, 1, &rule23},-	{1234, 1, &rule22},-	{1235, 1, &rule23},-	{1236, 1, &rule22},-	{1237, 1, &rule23},-	{1238, 1, &rule22},-	{1239, 1, &rule23},-	{1240, 1, &rule22},-	{1241, 1, &rule23},-	{1242, 1, &rule22},-	{1243, 1, &rule23},-	{1244, 1, &rule22},-	{1245, 1, &rule23},-	{1246, 1, &rule22},-	{1247, 1, &rule23},-	{1248, 1, &rule22},-	{1249, 1, &rule23},-	{1250, 1, &rule22},-	{1251, 1, &rule23},-	{1252, 1, &rule22},-	{1253, 1, &rule23},-	{1254, 1, &rule22},-	{1255, 1, &rule23},-	{1256, 1, &rule22},-	{1257, 1, &rule23},-	{1258, 1, &rule22},-	{1259, 1, &rule23},-	{1260, 1, &rule22},-	{1261, 1, &rule23},-	{1262, 1, &rule22},-	{1263, 1, &rule23},-	{1264, 1, &rule22},-	{1265, 1, &rule23},-	{1266, 1, &rule22},-	{1267, 1, &rule23},-	{1268, 1, &rule22},-	{1269, 1, &rule23},-	{1270, 1, &rule22},-	{1271, 1, &rule23},-	{1272, 1, &rule22},-	{1273, 1, &rule23},-	{1274, 1, &rule22},-	{1275, 1, &rule23},-	{1276, 1, &rule22},-	{1277, 1, &rule23},-	{1278, 1, &rule22},-	{1279, 1, &rule23},-	{1280, 1, &rule22},-	{1281, 1, &rule23},-	{1282, 1, &rule22},-	{1283, 1, &rule23},-	{1284, 1, &rule22},-	{1285, 1, &rule23},-	{1286, 1, &rule22},-	{1287, 1, &rule23},-	{1288, 1, &rule22},-	{1289, 1, &rule23},-	{1290, 1, &rule22},-	{1291, 1, &rule23},-	{1292, 1, &rule22},-	{1293, 1, &rule23},-	{1294, 1, &rule22},-	{1295, 1, &rule23},-	{1296, 1, &rule22},-	{1297, 1, &rule23},-	{1298, 1, &rule22},-	{1299, 1, &rule23},-	{1300, 1, &rule22},-	{1301, 1, &rule23},-	{1302, 1, &rule22},-	{1303, 1, &rule23},-	{1304, 1, &rule22},-	{1305, 1, &rule23},-	{1306, 1, &rule22},-	{1307, 1, &rule23},-	{1308, 1, &rule22},-	{1309, 1, &rule23},-	{1310, 1, &rule22},-	{1311, 1, &rule23},-	{1312, 1, &rule22},-	{1313, 1, &rule23},-	{1314, 1, &rule22},-	{1315, 1, &rule23},-	{1316, 1, &rule22},-	{1317, 1, &rule23},-	{1318, 1, &rule22},-	{1319, 1, &rule23},-	{1320, 1, &rule22},-	{1321, 1, &rule23},-	{1322, 1, &rule22},-	{1323, 1, &rule23},-	{1324, 1, &rule22},-	{1325, 1, &rule23},-	{1326, 1, &rule22},-	{1327, 1, &rule23},-	{1329, 38, &rule122},-	{1369, 1, &rule91},-	{1370, 6, &rule2},-	{1376, 1, &rule20},-	{1377, 38, &rule123},-	{1415, 2, &rule20},-	{1417, 1, &rule2},-	{1418, 1, &rule7},-	{1421, 2, &rule13},-	{1423, 1, &rule3},-	{1425, 45, &rule92},-	{1470, 1, &rule7},-	{1471, 1, &rule92},-	{1472, 1, &rule2},-	{1473, 2, &rule92},-	{1475, 1, &rule2},-	{1476, 2, &rule92},-	{1478, 1, &rule2},-	{1479, 1, &rule92},-	{1488, 27, &rule14},-	{1519, 4, &rule14},-	{1523, 2, &rule2},-	{1536, 6, &rule16},-	{1542, 3, &rule6},-	{1545, 2, &rule2},-	{1547, 1, &rule3},-	{1548, 2, &rule2},-	{1550, 2, &rule13},-	{1552, 11, &rule92},-	{1563, 1, &rule2},-	{1564, 1, &rule16},-	{1565, 3, &rule2},-	{1568, 32, &rule14},-	{1600, 1, &rule91},-	{1601, 10, &rule14},-	{1611, 21, &rule92},-	{1632, 10, &rule8},-	{1642, 4, &rule2},-	{1646, 2, &rule14},-	{1648, 1, &rule92},-	{1649, 99, &rule14},-	{1748, 1, &rule2},-	{1749, 1, &rule14},-	{1750, 7, &rule92},-	{1757, 1, &rule16},-	{1758, 1, &rule13},-	{1759, 6, &rule92},-	{1765, 2, &rule91},-	{1767, 2, &rule92},-	{1769, 1, &rule13},-	{1770, 4, &rule92},-	{1774, 2, &rule14},-	{1776, 10, &rule8},-	{1786, 3, &rule14},-	{1789, 2, &rule13},-	{1791, 1, &rule14},-	{1792, 14, &rule2},-	{1807, 1, &rule16},-	{1808, 1, &rule14},-	{1809, 1, &rule92},-	{1810, 30, &rule14},-	{1840, 27, &rule92},-	{1869, 89, &rule14},-	{1958, 11, &rule92},-	{1969, 1, &rule14},-	{1984, 10, &rule8},-	{1994, 33, &rule14},-	{2027, 9, &rule92},-	{2036, 2, &rule91},-	{2038, 1, &rule13},-	{2039, 3, &rule2},-	{2042, 1, &rule91},-	{2045, 1, &rule92},-	{2046, 2, &rule3},-	{2048, 22, &rule14},-	{2070, 4, &rule92},-	{2074, 1, &rule91},-	{2075, 9, &rule92},-	{2084, 1, &rule91},-	{2085, 3, &rule92},-	{2088, 1, &rule91},-	{2089, 5, &rule92},-	{2096, 15, &rule2},-	{2112, 25, &rule14},-	{2137, 3, &rule92},-	{2142, 1, &rule2},-	{2144, 11, &rule14},-	{2160, 24, &rule14},-	{2184, 1, &rule10},-	{2185, 6, &rule14},-	{2192, 2, &rule16},-	{2200, 8, &rule92},-	{2208, 41, &rule14},-	{2249, 1, &rule91},-	{2250, 24, &rule92},-	{2274, 1, &rule16},-	{2275, 32, &rule92},-	{2307, 1, &rule124},-	{2308, 54, &rule14},-	{2362, 1, &rule92},-	{2363, 1, &rule124},-	{2364, 1, &rule92},-	{2365, 1, &rule14},-	{2366, 3, &rule124},-	{2369, 8, &rule92},-	{2377, 4, &rule124},-	{2381, 1, &rule92},-	{2382, 2, &rule124},-	{2384, 1, &rule14},-	{2385, 7, &rule92},-	{2392, 10, &rule14},-	{2402, 2, &rule92},-	{2404, 2, &rule2},-	{2406, 10, &rule8},-	{2416, 1, &rule2},-	{2417, 1, &rule91},-	{2418, 15, &rule14},-	{2433, 1, &rule92},-	{2434, 2, &rule124},-	{2437, 8, &rule14},-	{2447, 2, &rule14},-	{2451, 22, &rule14},-	{2474, 7, &rule14},-	{2482, 1, &rule14},-	{2486, 4, &rule14},-	{2492, 1, &rule92},-	{2493, 1, &rule14},-	{2494, 3, &rule124},-	{2497, 4, &rule92},-	{2503, 2, &rule124},-	{2507, 2, &rule124},-	{2509, 1, &rule92},-	{2510, 1, &rule14},-	{2519, 1, &rule124},-	{2524, 2, &rule14},-	{2527, 3, &rule14},-	{2530, 2, &rule92},-	{2534, 10, &rule8},-	{2544, 2, &rule14},-	{2546, 2, &rule3},-	{2548, 6, &rule17},-	{2554, 1, &rule13},-	{2555, 1, &rule3},-	{2556, 1, &rule14},-	{2557, 1, &rule2},-	{2558, 1, &rule92},-	{2561, 2, &rule92},-	{2563, 1, &rule124},-	{2565, 6, &rule14},-	{2575, 2, &rule14},-	{2579, 22, &rule14},-	{2602, 7, &rule14},-	{2610, 2, &rule14},-	{2613, 2, &rule14},-	{2616, 2, &rule14},-	{2620, 1, &rule92},-	{2622, 3, &rule124},-	{2625, 2, &rule92},-	{2631, 2, &rule92},-	{2635, 3, &rule92},-	{2641, 1, &rule92},-	{2649, 4, &rule14},-	{2654, 1, &rule14},-	{2662, 10, &rule8},-	{2672, 2, &rule92},-	{2674, 3, &rule14},-	{2677, 1, &rule92},-	{2678, 1, &rule2},-	{2689, 2, &rule92},-	{2691, 1, &rule124},-	{2693, 9, &rule14},-	{2703, 3, &rule14},-	{2707, 22, &rule14},-	{2730, 7, &rule14},-	{2738, 2, &rule14},-	{2741, 5, &rule14},-	{2748, 1, &rule92},-	{2749, 1, &rule14},-	{2750, 3, &rule124},-	{2753, 5, &rule92},-	{2759, 2, &rule92},-	{2761, 1, &rule124},-	{2763, 2, &rule124},-	{2765, 1, &rule92},-	{2768, 1, &rule14},-	{2784, 2, &rule14},-	{2786, 2, &rule92},-	{2790, 10, &rule8},-	{2800, 1, &rule2},-	{2801, 1, &rule3},-	{2809, 1, &rule14},-	{2810, 6, &rule92},-	{2817, 1, &rule92},-	{2818, 2, &rule124},-	{2821, 8, &rule14},-	{2831, 2, &rule14},-	{2835, 22, &rule14},-	{2858, 7, &rule14},-	{2866, 2, &rule14},-	{2869, 5, &rule14},-	{2876, 1, &rule92},-	{2877, 1, &rule14},-	{2878, 1, &rule124},-	{2879, 1, &rule92},-	{2880, 1, &rule124},-	{2881, 4, &rule92},-	{2887, 2, &rule124},-	{2891, 2, &rule124},-	{2893, 1, &rule92},-	{2901, 2, &rule92},-	{2903, 1, &rule124},-	{2908, 2, &rule14},-	{2911, 3, &rule14},-	{2914, 2, &rule92},-	{2918, 10, &rule8},-	{2928, 1, &rule13},-	{2929, 1, &rule14},-	{2930, 6, &rule17},-	{2946, 1, &rule92},-	{2947, 1, &rule14},-	{2949, 6, &rule14},-	{2958, 3, &rule14},-	{2962, 4, &rule14},-	{2969, 2, &rule14},-	{2972, 1, &rule14},-	{2974, 2, &rule14},-	{2979, 2, &rule14},-	{2984, 3, &rule14},-	{2990, 12, &rule14},-	{3006, 2, &rule124},-	{3008, 1, &rule92},-	{3009, 2, &rule124},-	{3014, 3, &rule124},-	{3018, 3, &rule124},-	{3021, 1, &rule92},-	{3024, 1, &rule14},-	{3031, 1, &rule124},-	{3046, 10, &rule8},-	{3056, 3, &rule17},-	{3059, 6, &rule13},-	{3065, 1, &rule3},-	{3066, 1, &rule13},-	{3072, 1, &rule92},-	{3073, 3, &rule124},-	{3076, 1, &rule92},-	{3077, 8, &rule14},-	{3086, 3, &rule14},-	{3090, 23, &rule14},-	{3114, 16, &rule14},-	{3132, 1, &rule92},-	{3133, 1, &rule14},-	{3134, 3, &rule92},-	{3137, 4, &rule124},-	{3142, 3, &rule92},-	{3146, 4, &rule92},-	{3157, 2, &rule92},-	{3160, 3, &rule14},-	{3165, 1, &rule14},-	{3168, 2, &rule14},-	{3170, 2, &rule92},-	{3174, 10, &rule8},-	{3191, 1, &rule2},-	{3192, 7, &rule17},-	{3199, 1, &rule13},-	{3200, 1, &rule14},-	{3201, 1, &rule92},-	{3202, 2, &rule124},-	{3204, 1, &rule2},-	{3205, 8, &rule14},-	{3214, 3, &rule14},-	{3218, 23, &rule14},-	{3242, 10, &rule14},-	{3253, 5, &rule14},-	{3260, 1, &rule92},-	{3261, 1, &rule14},-	{3262, 1, &rule124},-	{3263, 1, &rule92},-	{3264, 5, &rule124},-	{3270, 1, &rule92},-	{3271, 2, &rule124},-	{3274, 2, &rule124},-	{3276, 2, &rule92},-	{3285, 2, &rule124},-	{3293, 2, &rule14},-	{3296, 2, &rule14},-	{3298, 2, &rule92},-	{3302, 10, &rule8},-	{3313, 2, &rule14},-	{3328, 2, &rule92},-	{3330, 2, &rule124},-	{3332, 9, &rule14},-	{3342, 3, &rule14},-	{3346, 41, &rule14},-	{3387, 2, &rule92},-	{3389, 1, &rule14},-	{3390, 3, &rule124},-	{3393, 4, &rule92},-	{3398, 3, &rule124},-	{3402, 3, &rule124},-	{3405, 1, &rule92},-	{3406, 1, &rule14},-	{3407, 1, &rule13},-	{3412, 3, &rule14},-	{3415, 1, &rule124},-	{3416, 7, &rule17},-	{3423, 3, &rule14},-	{3426, 2, &rule92},-	{3430, 10, &rule8},-	{3440, 9, &rule17},-	{3449, 1, &rule13},-	{3450, 6, &rule14},-	{3457, 1, &rule92},-	{3458, 2, &rule124},-	{3461, 18, &rule14},-	{3482, 24, &rule14},-	{3507, 9, &rule14},-	{3517, 1, &rule14},-	{3520, 7, &rule14},-	{3530, 1, &rule92},-	{3535, 3, &rule124},-	{3538, 3, &rule92},-	{3542, 1, &rule92},-	{3544, 8, &rule124},-	{3558, 10, &rule8},-	{3570, 2, &rule124},-	{3572, 1, &rule2},-	{3585, 48, &rule14},-	{3633, 1, &rule92},-	{3634, 2, &rule14},-	{3636, 7, &rule92},-	{3647, 1, &rule3},-	{3648, 6, &rule14},-	{3654, 1, &rule91},-	{3655, 8, &rule92},-	{3663, 1, &rule2},-	{3664, 10, &rule8},-	{3674, 2, &rule2},-	{3713, 2, &rule14},-	{3716, 1, &rule14},-	{3718, 5, &rule14},-	{3724, 24, &rule14},-	{3749, 1, &rule14},-	{3751, 10, &rule14},-	{3761, 1, &rule92},-	{3762, 2, &rule14},-	{3764, 9, &rule92},-	{3773, 1, &rule14},-	{3776, 5, &rule14},-	{3782, 1, &rule91},-	{3784, 6, &rule92},-	{3792, 10, &rule8},-	{3804, 4, &rule14},-	{3840, 1, &rule14},-	{3841, 3, &rule13},-	{3844, 15, &rule2},-	{3859, 1, &rule13},-	{3860, 1, &rule2},-	{3861, 3, &rule13},-	{3864, 2, &rule92},-	{3866, 6, &rule13},-	{3872, 10, &rule8},-	{3882, 10, &rule17},-	{3892, 1, &rule13},-	{3893, 1, &rule92},-	{3894, 1, &rule13},-	{3895, 1, &rule92},-	{3896, 1, &rule13},-	{3897, 1, &rule92},-	{3898, 1, &rule4},-	{3899, 1, &rule5},-	{3900, 1, &rule4},-	{3901, 1, &rule5},-	{3902, 2, &rule124},-	{3904, 8, &rule14},-	{3913, 36, &rule14},-	{3953, 14, &rule92},-	{3967, 1, &rule124},-	{3968, 5, &rule92},-	{3973, 1, &rule2},-	{3974, 2, &rule92},-	{3976, 5, &rule14},-	{3981, 11, &rule92},-	{3993, 36, &rule92},-	{4030, 8, &rule13},-	{4038, 1, &rule92},-	{4039, 6, &rule13},-	{4046, 2, &rule13},-	{4048, 5, &rule2},-	{4053, 4, &rule13},-	{4057, 2, &rule2},-	{4096, 43, &rule14},-	{4139, 2, &rule124},-	{4141, 4, &rule92},-	{4145, 1, &rule124},-	{4146, 6, &rule92},-	{4152, 1, &rule124},-	{4153, 2, &rule92},-	{4155, 2, &rule124},-	{4157, 2, &rule92},-	{4159, 1, &rule14},-	{4160, 10, &rule8},-	{4170, 6, &rule2},-	{4176, 6, &rule14},-	{4182, 2, &rule124},-	{4184, 2, &rule92},-	{4186, 4, &rule14},-	{4190, 3, &rule92},-	{4193, 1, &rule14},-	{4194, 3, &rule124},-	{4197, 2, &rule14},-	{4199, 7, &rule124},-	{4206, 3, &rule14},-	{4209, 4, &rule92},-	{4213, 13, &rule14},-	{4226, 1, &rule92},-	{4227, 2, &rule124},-	{4229, 2, &rule92},-	{4231, 6, &rule124},-	{4237, 1, &rule92},-	{4238, 1, &rule14},-	{4239, 1, &rule124},-	{4240, 10, &rule8},-	{4250, 3, &rule124},-	{4253, 1, &rule92},-	{4254, 2, &rule13},-	{4256, 38, &rule125},-	{4295, 1, &rule125},-	{4301, 1, &rule125},-	{4304, 43, &rule126},-	{4347, 1, &rule2},-	{4348, 1, &rule91},-	{4349, 3, &rule126},-	{4352, 329, &rule14},-	{4682, 4, &rule14},-	{4688, 7, &rule14},-	{4696, 1, &rule14},-	{4698, 4, &rule14},-	{4704, 41, &rule14},-	{4746, 4, &rule14},-	{4752, 33, &rule14},-	{4786, 4, &rule14},-	{4792, 7, &rule14},-	{4800, 1, &rule14},-	{4802, 4, &rule14},-	{4808, 15, &rule14},-	{4824, 57, &rule14},-	{4882, 4, &rule14},-	{4888, 67, &rule14},-	{4957, 3, &rule92},-	{4960, 9, &rule2},-	{4969, 20, &rule17},-	{4992, 16, &rule14},-	{5008, 10, &rule13},-	{5024, 80, &rule127},-	{5104, 6, &rule104},-	{5112, 6, &rule110},-	{5120, 1, &rule7},-	{5121, 620, &rule14},-	{5741, 1, &rule13},-	{5742, 1, &rule2},-	{5743, 17, &rule14},-	{5760, 1, &rule1},-	{5761, 26, &rule14},-	{5787, 1, &rule4},-	{5788, 1, &rule5},-	{5792, 75, &rule14},-	{5867, 3, &rule2},-	{5870, 3, &rule128},-	{5873, 8, &rule14},-	{5888, 18, &rule14},-	{5906, 3, &rule92},-	{5909, 1, &rule124},-	{5919, 19, &rule14},-	{5938, 2, &rule92},-	{5940, 1, &rule124},-	{5941, 2, &rule2},-	{5952, 18, &rule14},-	{5970, 2, &rule92},-	{5984, 13, &rule14},-	{5998, 3, &rule14},-	{6002, 2, &rule92},-	{6016, 52, &rule14},-	{6068, 2, &rule92},-	{6070, 1, &rule124},-	{6071, 7, &rule92},-	{6078, 8, &rule124},-	{6086, 1, &rule92},-	{6087, 2, &rule124},-	{6089, 11, &rule92},-	{6100, 3, &rule2},-	{6103, 1, &rule91},-	{6104, 3, &rule2},-	{6107, 1, &rule3},-	{6108, 1, &rule14},-	{6109, 1, &rule92},-	{6112, 10, &rule8},-	{6128, 10, &rule17},-	{6144, 6, &rule2},-	{6150, 1, &rule7},-	{6151, 4, &rule2},-	{6155, 3, &rule92},-	{6158, 1, &rule16},-	{6159, 1, &rule92},-	{6160, 10, &rule8},-	{6176, 35, &rule14},-	{6211, 1, &rule91},-	{6212, 53, &rule14},-	{6272, 5, &rule14},-	{6277, 2, &rule92},-	{6279, 34, &rule14},-	{6313, 1, &rule92},-	{6314, 1, &rule14},-	{6320, 70, &rule14},-	{6400, 31, &rule14},-	{6432, 3, &rule92},-	{6435, 4, &rule124},-	{6439, 2, &rule92},-	{6441, 3, &rule124},-	{6448, 2, &rule124},-	{6450, 1, &rule92},-	{6451, 6, &rule124},-	{6457, 3, &rule92},-	{6464, 1, &rule13},-	{6468, 2, &rule2},-	{6470, 10, &rule8},-	{6480, 30, &rule14},-	{6512, 5, &rule14},-	{6528, 44, &rule14},-	{6576, 26, &rule14},-	{6608, 10, &rule8},-	{6618, 1, &rule17},-	{6622, 34, &rule13},-	{6656, 23, &rule14},-	{6679, 2, &rule92},-	{6681, 2, &rule124},-	{6683, 1, &rule92},-	{6686, 2, &rule2},-	{6688, 53, &rule14},-	{6741, 1, &rule124},-	{6742, 1, &rule92},-	{6743, 1, &rule124},-	{6744, 7, &rule92},-	{6752, 1, &rule92},-	{6753, 1, &rule124},-	{6754, 1, &rule92},-	{6755, 2, &rule124},-	{6757, 8, &rule92},-	{6765, 6, &rule124},-	{6771, 10, &rule92},-	{6783, 1, &rule92},-	{6784, 10, &rule8},-	{6800, 10, &rule8},-	{6816, 7, &rule2},-	{6823, 1, &rule91},-	{6824, 6, &rule2},-	{6832, 14, &rule92},-	{6846, 1, &rule119},-	{6847, 16, &rule92},-	{6912, 4, &rule92},-	{6916, 1, &rule124},-	{6917, 47, &rule14},-	{6964, 1, &rule92},-	{6965, 1, &rule124},-	{6966, 5, &rule92},-	{6971, 1, &rule124},-	{6972, 1, &rule92},-	{6973, 5, &rule124},-	{6978, 1, &rule92},-	{6979, 2, &rule124},-	{6981, 8, &rule14},-	{6992, 10, &rule8},-	{7002, 7, &rule2},-	{7009, 10, &rule13},-	{7019, 9, &rule92},-	{7028, 9, &rule13},-	{7037, 2, &rule2},-	{7040, 2, &rule92},-	{7042, 1, &rule124},-	{7043, 30, &rule14},-	{7073, 1, &rule124},-	{7074, 4, &rule92},-	{7078, 2, &rule124},-	{7080, 2, &rule92},-	{7082, 1, &rule124},-	{7083, 3, &rule92},-	{7086, 2, &rule14},-	{7088, 10, &rule8},-	{7098, 44, &rule14},-	{7142, 1, &rule92},-	{7143, 1, &rule124},-	{7144, 2, &rule92},-	{7146, 3, &rule124},-	{7149, 1, &rule92},-	{7150, 1, &rule124},-	{7151, 3, &rule92},-	{7154, 2, &rule124},-	{7164, 4, &rule2},-	{7168, 36, &rule14},-	{7204, 8, &rule124},-	{7212, 8, &rule92},-	{7220, 2, &rule124},-	{7222, 2, &rule92},-	{7227, 5, &rule2},-	{7232, 10, &rule8},-	{7245, 3, &rule14},-	{7248, 10, &rule8},-	{7258, 30, &rule14},-	{7288, 6, &rule91},-	{7294, 2, &rule2},-	{7296, 1, &rule129},-	{7297, 1, &rule130},-	{7298, 1, &rule131},-	{7299, 2, &rule132},-	{7301, 1, &rule133},-	{7302, 1, &rule134},-	{7303, 1, &rule135},-	{7304, 1, &rule136},-	{7312, 43, &rule137},-	{7357, 3, &rule137},-	{7360, 8, &rule2},-	{7376, 3, &rule92},-	{7379, 1, &rule2},-	{7380, 13, &rule92},-	{7393, 1, &rule124},-	{7394, 7, &rule92},-	{7401, 4, &rule14},-	{7405, 1, &rule92},-	{7406, 6, &rule14},-	{7412, 1, &rule92},-	{7413, 2, &rule14},-	{7415, 1, &rule124},-	{7416, 2, &rule92},-	{7418, 1, &rule14},-	{7424, 44, &rule20},-	{7468, 63, &rule91},-	{7531, 13, &rule20},-	{7544, 1, &rule91},-	{7545, 1, &rule138},-	{7546, 3, &rule20},-	{7549, 1, &rule139},-	{7550, 16, &rule20},-	{7566, 1, &rule140},-	{7567, 12, &rule20},-	{7579, 37, &rule91},-	{7616, 64, &rule92},-	{7680, 1, &rule22},-	{7681, 1, &rule23},-	{7682, 1, &rule22},-	{7683, 1, &rule23},-	{7684, 1, &rule22},-	{7685, 1, &rule23},-	{7686, 1, &rule22},-	{7687, 1, &rule23},-	{7688, 1, &rule22},-	{7689, 1, &rule23},-	{7690, 1, &rule22},-	{7691, 1, &rule23},-	{7692, 1, &rule22},-	{7693, 1, &rule23},-	{7694, 1, &rule22},-	{7695, 1, &rule23},-	{7696, 1, &rule22},-	{7697, 1, &rule23},-	{7698, 1, &rule22},-	{7699, 1, &rule23},-	{7700, 1, &rule22},-	{7701, 1, &rule23},-	{7702, 1, &rule22},-	{7703, 1, &rule23},-	{7704, 1, &rule22},-	{7705, 1, &rule23},-	{7706, 1, &rule22},-	{7707, 1, &rule23},-	{7708, 1, &rule22},-	{7709, 1, &rule23},-	{7710, 1, &rule22},-	{7711, 1, &rule23},-	{7712, 1, &rule22},-	{7713, 1, &rule23},-	{7714, 1, &rule22},-	{7715, 1, &rule23},-	{7716, 1, &rule22},-	{7717, 1, &rule23},-	{7718, 1, &rule22},-	{7719, 1, &rule23},-	{7720, 1, &rule22},-	{7721, 1, &rule23},-	{7722, 1, &rule22},-	{7723, 1, &rule23},-	{7724, 1, &rule22},-	{7725, 1, &rule23},-	{7726, 1, &rule22},-	{7727, 1, &rule23},-	{7728, 1, &rule22},-	{7729, 1, &rule23},-	{7730, 1, &rule22},-	{7731, 1, &rule23},-	{7732, 1, &rule22},-	{7733, 1, &rule23},-	{7734, 1, &rule22},-	{7735, 1, &rule23},-	{7736, 1, &rule22},-	{7737, 1, &rule23},-	{7738, 1, &rule22},-	{7739, 1, &rule23},-	{7740, 1, &rule22},-	{7741, 1, &rule23},-	{7742, 1, &rule22},-	{7743, 1, &rule23},-	{7744, 1, &rule22},-	{7745, 1, &rule23},-	{7746, 1, &rule22},-	{7747, 1, &rule23},-	{7748, 1, &rule22},-	{7749, 1, &rule23},-	{7750, 1, &rule22},-	{7751, 1, &rule23},-	{7752, 1, &rule22},-	{7753, 1, &rule23},-	{7754, 1, &rule22},-	{7755, 1, &rule23},-	{7756, 1, &rule22},-	{7757, 1, &rule23},-	{7758, 1, &rule22},-	{7759, 1, &rule23},-	{7760, 1, &rule22},-	{7761, 1, &rule23},-	{7762, 1, &rule22},-	{7763, 1, &rule23},-	{7764, 1, &rule22},-	{7765, 1, &rule23},-	{7766, 1, &rule22},-	{7767, 1, &rule23},-	{7768, 1, &rule22},-	{7769, 1, &rule23},-	{7770, 1, &rule22},-	{7771, 1, &rule23},-	{7772, 1, &rule22},-	{7773, 1, &rule23},-	{7774, 1, &rule22},-	{7775, 1, &rule23},-	{7776, 1, &rule22},-	{7777, 1, &rule23},-	{7778, 1, &rule22},-	{7779, 1, &rule23},-	{7780, 1, &rule22},-	{7781, 1, &rule23},-	{7782, 1, &rule22},-	{7783, 1, &rule23},-	{7784, 1, &rule22},-	{7785, 1, &rule23},-	{7786, 1, &rule22},-	{7787, 1, &rule23},-	{7788, 1, &rule22},-	{7789, 1, &rule23},-	{7790, 1, &rule22},-	{7791, 1, &rule23},-	{7792, 1, &rule22},-	{7793, 1, &rule23},-	{7794, 1, &rule22},-	{7795, 1, &rule23},-	{7796, 1, &rule22},-	{7797, 1, &rule23},-	{7798, 1, &rule22},-	{7799, 1, &rule23},-	{7800, 1, &rule22},-	{7801, 1, &rule23},-	{7802, 1, &rule22},-	{7803, 1, &rule23},-	{7804, 1, &rule22},-	{7805, 1, &rule23},-	{7806, 1, &rule22},-	{7807, 1, &rule23},-	{7808, 1, &rule22},-	{7809, 1, &rule23},-	{7810, 1, &rule22},-	{7811, 1, &rule23},-	{7812, 1, &rule22},-	{7813, 1, &rule23},-	{7814, 1, &rule22},-	{7815, 1, &rule23},-	{7816, 1, &rule22},-	{7817, 1, &rule23},-	{7818, 1, &rule22},-	{7819, 1, &rule23},-	{7820, 1, &rule22},-	{7821, 1, &rule23},-	{7822, 1, &rule22},-	{7823, 1, &rule23},-	{7824, 1, &rule22},-	{7825, 1, &rule23},-	{7826, 1, &rule22},-	{7827, 1, &rule23},-	{7828, 1, &rule22},-	{7829, 1, &rule23},-	{7830, 5, &rule20},-	{7835, 1, &rule141},-	{7836, 2, &rule20},-	{7838, 1, &rule142},-	{7839, 1, &rule20},-	{7840, 1, &rule22},-	{7841, 1, &rule23},-	{7842, 1, &rule22},-	{7843, 1, &rule23},-	{7844, 1, &rule22},-	{7845, 1, &rule23},-	{7846, 1, &rule22},-	{7847, 1, &rule23},-	{7848, 1, &rule22},-	{7849, 1, &rule23},-	{7850, 1, &rule22},-	{7851, 1, &rule23},-	{7852, 1, &rule22},-	{7853, 1, &rule23},-	{7854, 1, &rule22},-	{7855, 1, &rule23},-	{7856, 1, &rule22},-	{7857, 1, &rule23},-	{7858, 1, &rule22},-	{7859, 1, &rule23},-	{7860, 1, &rule22},-	{7861, 1, &rule23},-	{7862, 1, &rule22},-	{7863, 1, &rule23},-	{7864, 1, &rule22},-	{7865, 1, &rule23},-	{7866, 1, &rule22},-	{7867, 1, &rule23},-	{7868, 1, &rule22},-	{7869, 1, &rule23},-	{7870, 1, &rule22},-	{7871, 1, &rule23},-	{7872, 1, &rule22},-	{7873, 1, &rule23},-	{7874, 1, &rule22},-	{7875, 1, &rule23},-	{7876, 1, &rule22},-	{7877, 1, &rule23},-	{7878, 1, &rule22},-	{7879, 1, &rule23},-	{7880, 1, &rule22},-	{7881, 1, &rule23},-	{7882, 1, &rule22},-	{7883, 1, &rule23},-	{7884, 1, &rule22},-	{7885, 1, &rule23},-	{7886, 1, &rule22},-	{7887, 1, &rule23},-	{7888, 1, &rule22},-	{7889, 1, &rule23},-	{7890, 1, &rule22},-	{7891, 1, &rule23},-	{7892, 1, &rule22},-	{7893, 1, &rule23},-	{7894, 1, &rule22},-	{7895, 1, &rule23},-	{7896, 1, &rule22},-	{7897, 1, &rule23},-	{7898, 1, &rule22},-	{7899, 1, &rule23},-	{7900, 1, &rule22},-	{7901, 1, &rule23},-	{7902, 1, &rule22},-	{7903, 1, &rule23},-	{7904, 1, &rule22},-	{7905, 1, &rule23},-	{7906, 1, &rule22},-	{7907, 1, &rule23},-	{7908, 1, &rule22},-	{7909, 1, &rule23},-	{7910, 1, &rule22},-	{7911, 1, &rule23},-	{7912, 1, &rule22},-	{7913, 1, &rule23},-	{7914, 1, &rule22},-	{7915, 1, &rule23},-	{7916, 1, &rule22},-	{7917, 1, &rule23},-	{7918, 1, &rule22},-	{7919, 1, &rule23},-	{7920, 1, &rule22},-	{7921, 1, &rule23},-	{7922, 1, &rule22},-	{7923, 1, &rule23},-	{7924, 1, &rule22},-	{7925, 1, &rule23},-	{7926, 1, &rule22},-	{7927, 1, &rule23},-	{7928, 1, &rule22},-	{7929, 1, &rule23},-	{7930, 1, &rule22},-	{7931, 1, &rule23},-	{7932, 1, &rule22},-	{7933, 1, &rule23},-	{7934, 1, &rule22},-	{7935, 1, &rule23},-	{7936, 8, &rule143},-	{7944, 8, &rule144},-	{7952, 6, &rule143},-	{7960, 6, &rule144},-	{7968, 8, &rule143},-	{7976, 8, &rule144},-	{7984, 8, &rule143},-	{7992, 8, &rule144},-	{8000, 6, &rule143},-	{8008, 6, &rule144},-	{8016, 1, &rule20},-	{8017, 1, &rule143},-	{8018, 1, &rule20},-	{8019, 1, &rule143},-	{8020, 1, &rule20},-	{8021, 1, &rule143},-	{8022, 1, &rule20},-	{8023, 1, &rule143},-	{8025, 1, &rule144},-	{8027, 1, &rule144},-	{8029, 1, &rule144},-	{8031, 1, &rule144},-	{8032, 8, &rule143},-	{8040, 8, &rule144},-	{8048, 2, &rule145},-	{8050, 4, &rule146},-	{8054, 2, &rule147},-	{8056, 2, &rule148},-	{8058, 2, &rule149},-	{8060, 2, &rule150},-	{8064, 8, &rule143},-	{8072, 8, &rule151},-	{8080, 8, &rule143},-	{8088, 8, &rule151},-	{8096, 8, &rule143},-	{8104, 8, &rule151},-	{8112, 2, &rule143},-	{8114, 1, &rule20},-	{8115, 1, &rule152},-	{8116, 1, &rule20},-	{8118, 2, &rule20},-	{8120, 2, &rule144},-	{8122, 2, &rule153},-	{8124, 1, &rule154},-	{8125, 1, &rule10},-	{8126, 1, &rule155},-	{8127, 3, &rule10},-	{8130, 1, &rule20},-	{8131, 1, &rule152},-	{8132, 1, &rule20},-	{8134, 2, &rule20},-	{8136, 4, &rule156},-	{8140, 1, &rule154},-	{8141, 3, &rule10},-	{8144, 2, &rule143},-	{8146, 2, &rule20},-	{8150, 2, &rule20},-	{8152, 2, &rule144},-	{8154, 2, &rule157},-	{8157, 3, &rule10},-	{8160, 2, &rule143},-	{8162, 3, &rule20},-	{8165, 1, &rule113},-	{8166, 2, &rule20},-	{8168, 2, &rule144},-	{8170, 2, &rule158},-	{8172, 1, &rule117},-	{8173, 3, &rule10},-	{8178, 1, &rule20},-	{8179, 1, &rule152},-	{8180, 1, &rule20},-	{8182, 2, &rule20},-	{8184, 2, &rule159},-	{8186, 2, &rule160},-	{8188, 1, &rule154},-	{8189, 2, &rule10},-	{8192, 11, &rule1},-	{8203, 5, &rule16},-	{8208, 6, &rule7},-	{8214, 2, &rule2},-	{8216, 1, &rule15},-	{8217, 1, &rule19},-	{8218, 1, &rule4},-	{8219, 2, &rule15},-	{8221, 1, &rule19},-	{8222, 1, &rule4},-	{8223, 1, &rule15},-	{8224, 8, &rule2},-	{8232, 1, &rule161},-	{8233, 1, &rule162},-	{8234, 5, &rule16},-	{8239, 1, &rule1},-	{8240, 9, &rule2},-	{8249, 1, &rule15},-	{8250, 1, &rule19},-	{8251, 4, &rule2},-	{8255, 2, &rule11},-	{8257, 3, &rule2},-	{8260, 1, &rule6},-	{8261, 1, &rule4},-	{8262, 1, &rule5},-	{8263, 11, &rule2},-	{8274, 1, &rule6},-	{8275, 1, &rule2},-	{8276, 1, &rule11},-	{8277, 10, &rule2},-	{8287, 1, &rule1},-	{8288, 5, &rule16},-	{8294, 10, &rule16},-	{8304, 1, &rule17},-	{8305, 1, &rule91},-	{8308, 6, &rule17},-	{8314, 3, &rule6},-	{8317, 1, &rule4},-	{8318, 1, &rule5},-	{8319, 1, &rule91},-	{8320, 10, &rule17},-	{8330, 3, &rule6},-	{8333, 1, &rule4},-	{8334, 1, &rule5},-	{8336, 13, &rule91},-	{8352, 33, &rule3},-	{8400, 13, &rule92},-	{8413, 4, &rule119},-	{8417, 1, &rule92},-	{8418, 3, &rule119},-	{8421, 12, &rule92},-	{8448, 2, &rule13},-	{8450, 1, &rule107},-	{8451, 4, &rule13},-	{8455, 1, &rule107},-	{8456, 2, &rule13},-	{8458, 1, &rule20},-	{8459, 3, &rule107},-	{8462, 2, &rule20},-	{8464, 3, &rule107},-	{8467, 1, &rule20},-	{8468, 1, &rule13},-	{8469, 1, &rule107},-	{8470, 2, &rule13},-	{8472, 1, &rule6},-	{8473, 5, &rule107},-	{8478, 6, &rule13},-	{8484, 1, &rule107},-	{8485, 1, &rule13},-	{8486, 1, &rule163},-	{8487, 1, &rule13},-	{8488, 1, &rule107},-	{8489, 1, &rule13},-	{8490, 1, &rule164},-	{8491, 1, &rule165},-	{8492, 2, &rule107},-	{8494, 1, &rule13},-	{8495, 1, &rule20},-	{8496, 2, &rule107},-	{8498, 1, &rule166},-	{8499, 1, &rule107},-	{8500, 1, &rule20},-	{8501, 4, &rule14},-	{8505, 1, &rule20},-	{8506, 2, &rule13},-	{8508, 2, &rule20},-	{8510, 2, &rule107},-	{8512, 5, &rule6},-	{8517, 1, &rule107},-	{8518, 4, &rule20},-	{8522, 1, &rule13},-	{8523, 1, &rule6},-	{8524, 2, &rule13},-	{8526, 1, &rule167},-	{8527, 1, &rule13},-	{8528, 16, &rule17},-	{8544, 16, &rule168},-	{8560, 16, &rule169},-	{8576, 3, &rule128},-	{8579, 1, &rule22},-	{8580, 1, &rule23},-	{8581, 4, &rule128},-	{8585, 1, &rule17},-	{8586, 2, &rule13},-	{8592, 5, &rule6},-	{8597, 5, &rule13},-	{8602, 2, &rule6},-	{8604, 4, &rule13},-	{8608, 1, &rule6},-	{8609, 2, &rule13},-	{8611, 1, &rule6},-	{8612, 2, &rule13},-	{8614, 1, &rule6},-	{8615, 7, &rule13},-	{8622, 1, &rule6},-	{8623, 31, &rule13},-	{8654, 2, &rule6},-	{8656, 2, &rule13},-	{8658, 1, &rule6},-	{8659, 1, &rule13},-	{8660, 1, &rule6},-	{8661, 31, &rule13},-	{8692, 268, &rule6},-	{8960, 8, &rule13},-	{8968, 1, &rule4},-	{8969, 1, &rule5},-	{8970, 1, &rule4},-	{8971, 1, &rule5},-	{8972, 20, &rule13},-	{8992, 2, &rule6},-	{8994, 7, &rule13},-	{9001, 1, &rule4},-	{9002, 1, &rule5},-	{9003, 81, &rule13},-	{9084, 1, &rule6},-	{9085, 30, &rule13},-	{9115, 25, &rule6},-	{9140, 40, &rule13},-	{9180, 6, &rule6},-	{9186, 69, &rule13},-	{9280, 11, &rule13},-	{9312, 60, &rule17},-	{9372, 26, &rule13},-	{9398, 26, &rule170},-	{9424, 26, &rule171},-	{9450, 22, &rule17},-	{9472, 183, &rule13},-	{9655, 1, &rule6},-	{9656, 9, &rule13},-	{9665, 1, &rule6},-	{9666, 54, &rule13},-	{9720, 8, &rule6},-	{9728, 111, &rule13},-	{9839, 1, &rule6},-	{9840, 248, &rule13},-	{10088, 1, &rule4},-	{10089, 1, &rule5},-	{10090, 1, &rule4},-	{10091, 1, &rule5},-	{10092, 1, &rule4},-	{10093, 1, &rule5},-	{10094, 1, &rule4},-	{10095, 1, &rule5},-	{10096, 1, &rule4},-	{10097, 1, &rule5},-	{10098, 1, &rule4},-	{10099, 1, &rule5},-	{10100, 1, &rule4},-	{10101, 1, &rule5},-	{10102, 30, &rule17},-	{10132, 44, &rule13},-	{10176, 5, &rule6},-	{10181, 1, &rule4},-	{10182, 1, &rule5},-	{10183, 31, &rule6},-	{10214, 1, &rule4},-	{10215, 1, &rule5},-	{10216, 1, &rule4},-	{10217, 1, &rule5},-	{10218, 1, &rule4},-	{10219, 1, &rule5},-	{10220, 1, &rule4},-	{10221, 1, &rule5},-	{10222, 1, &rule4},-	{10223, 1, &rule5},-	{10224, 16, &rule6},-	{10240, 256, &rule13},-	{10496, 131, &rule6},-	{10627, 1, &rule4},-	{10628, 1, &rule5},-	{10629, 1, &rule4},-	{10630, 1, &rule5},-	{10631, 1, &rule4},-	{10632, 1, &rule5},-	{10633, 1, &rule4},-	{10634, 1, &rule5},-	{10635, 1, &rule4},-	{10636, 1, &rule5},-	{10637, 1, &rule4},-	{10638, 1, &rule5},-	{10639, 1, &rule4},-	{10640, 1, &rule5},-	{10641, 1, &rule4},-	{10642, 1, &rule5},-	{10643, 1, &rule4},-	{10644, 1, &rule5},-	{10645, 1, &rule4},-	{10646, 1, &rule5},-	{10647, 1, &rule4},-	{10648, 1, &rule5},-	{10649, 63, &rule6},-	{10712, 1, &rule4},-	{10713, 1, &rule5},-	{10714, 1, &rule4},-	{10715, 1, &rule5},-	{10716, 32, &rule6},-	{10748, 1, &rule4},-	{10749, 1, &rule5},-	{10750, 258, &rule6},-	{11008, 48, &rule13},-	{11056, 21, &rule6},-	{11077, 2, &rule13},-	{11079, 6, &rule6},-	{11085, 39, &rule13},-	{11126, 32, &rule13},-	{11159, 105, &rule13},-	{11264, 48, &rule122},-	{11312, 48, &rule123},-	{11360, 1, &rule22},-	{11361, 1, &rule23},-	{11362, 1, &rule172},-	{11363, 1, &rule173},-	{11364, 1, &rule174},-	{11365, 1, &rule175},-	{11366, 1, &rule176},-	{11367, 1, &rule22},-	{11368, 1, &rule23},-	{11369, 1, &rule22},-	{11370, 1, &rule23},-	{11371, 1, &rule22},-	{11372, 1, &rule23},-	{11373, 1, &rule177},-	{11374, 1, &rule178},-	{11375, 1, &rule179},-	{11376, 1, &rule180},-	{11377, 1, &rule20},-	{11378, 1, &rule22},-	{11379, 1, &rule23},-	{11380, 1, &rule20},-	{11381, 1, &rule22},-	{11382, 1, &rule23},-	{11383, 5, &rule20},-	{11388, 2, &rule91},-	{11390, 2, &rule181},-	{11392, 1, &rule22},-	{11393, 1, &rule23},-	{11394, 1, &rule22},-	{11395, 1, &rule23},-	{11396, 1, &rule22},-	{11397, 1, &rule23},-	{11398, 1, &rule22},-	{11399, 1, &rule23},-	{11400, 1, &rule22},-	{11401, 1, &rule23},-	{11402, 1, &rule22},-	{11403, 1, &rule23},-	{11404, 1, &rule22},-	{11405, 1, &rule23},-	{11406, 1, &rule22},-	{11407, 1, &rule23},-	{11408, 1, &rule22},-	{11409, 1, &rule23},-	{11410, 1, &rule22},-	{11411, 1, &rule23},-	{11412, 1, &rule22},-	{11413, 1, &rule23},-	{11414, 1, &rule22},-	{11415, 1, &rule23},-	{11416, 1, &rule22},-	{11417, 1, &rule23},-	{11418, 1, &rule22},-	{11419, 1, &rule23},-	{11420, 1, &rule22},-	{11421, 1, &rule23},-	{11422, 1, &rule22},-	{11423, 1, &rule23},-	{11424, 1, &rule22},-	{11425, 1, &rule23},-	{11426, 1, &rule22},-	{11427, 1, &rule23},-	{11428, 1, &rule22},-	{11429, 1, &rule23},-	{11430, 1, &rule22},-	{11431, 1, &rule23},-	{11432, 1, &rule22},-	{11433, 1, &rule23},-	{11434, 1, &rule22},-	{11435, 1, &rule23},-	{11436, 1, &rule22},-	{11437, 1, &rule23},-	{11438, 1, &rule22},-	{11439, 1, &rule23},-	{11440, 1, &rule22},-	{11441, 1, &rule23},-	{11442, 1, &rule22},-	{11443, 1, &rule23},-	{11444, 1, &rule22},-	{11445, 1, &rule23},-	{11446, 1, &rule22},-	{11447, 1, &rule23},-	{11448, 1, &rule22},-	{11449, 1, &rule23},-	{11450, 1, &rule22},-	{11451, 1, &rule23},-	{11452, 1, &rule22},-	{11453, 1, &rule23},-	{11454, 1, &rule22},-	{11455, 1, &rule23},-	{11456, 1, &rule22},-	{11457, 1, &rule23},-	{11458, 1, &rule22},-	{11459, 1, &rule23},-	{11460, 1, &rule22},-	{11461, 1, &rule23},-	{11462, 1, &rule22},-	{11463, 1, &rule23},-	{11464, 1, &rule22},-	{11465, 1, &rule23},-	{11466, 1, &rule22},-	{11467, 1, &rule23},-	{11468, 1, &rule22},-	{11469, 1, &rule23},-	{11470, 1, &rule22},-	{11471, 1, &rule23},-	{11472, 1, &rule22},-	{11473, 1, &rule23},-	{11474, 1, &rule22},-	{11475, 1, &rule23},-	{11476, 1, &rule22},-	{11477, 1, &rule23},-	{11478, 1, &rule22},-	{11479, 1, &rule23},-	{11480, 1, &rule22},-	{11481, 1, &rule23},-	{11482, 1, &rule22},-	{11483, 1, &rule23},-	{11484, 1, &rule22},-	{11485, 1, &rule23},-	{11486, 1, &rule22},-	{11487, 1, &rule23},-	{11488, 1, &rule22},-	{11489, 1, &rule23},-	{11490, 1, &rule22},-	{11491, 1, &rule23},-	{11492, 1, &rule20},-	{11493, 6, &rule13},-	{11499, 1, &rule22},-	{11500, 1, &rule23},-	{11501, 1, &rule22},-	{11502, 1, &rule23},-	{11503, 3, &rule92},-	{11506, 1, &rule22},-	{11507, 1, &rule23},-	{11513, 4, &rule2},-	{11517, 1, &rule17},-	{11518, 2, &rule2},-	{11520, 38, &rule182},-	{11559, 1, &rule182},-	{11565, 1, &rule182},-	{11568, 56, &rule14},-	{11631, 1, &rule91},-	{11632, 1, &rule2},-	{11647, 1, &rule92},-	{11648, 23, &rule14},-	{11680, 7, &rule14},-	{11688, 7, &rule14},-	{11696, 7, &rule14},-	{11704, 7, &rule14},-	{11712, 7, &rule14},-	{11720, 7, &rule14},-	{11728, 7, &rule14},-	{11736, 7, &rule14},-	{11744, 32, &rule92},-	{11776, 2, &rule2},-	{11778, 1, &rule15},-	{11779, 1, &rule19},-	{11780, 1, &rule15},-	{11781, 1, &rule19},-	{11782, 3, &rule2},-	{11785, 1, &rule15},-	{11786, 1, &rule19},-	{11787, 1, &rule2},-	{11788, 1, &rule15},-	{11789, 1, &rule19},-	{11790, 9, &rule2},-	{11799, 1, &rule7},-	{11800, 2, &rule2},-	{11802, 1, &rule7},-	{11803, 1, &rule2},-	{11804, 1, &rule15},-	{11805, 1, &rule19},-	{11806, 2, &rule2},-	{11808, 1, &rule15},-	{11809, 1, &rule19},-	{11810, 1, &rule4},-	{11811, 1, &rule5},-	{11812, 1, &rule4},-	{11813, 1, &rule5},-	{11814, 1, &rule4},-	{11815, 1, &rule5},-	{11816, 1, &rule4},-	{11817, 1, &rule5},-	{11818, 5, &rule2},-	{11823, 1, &rule91},-	{11824, 10, &rule2},-	{11834, 2, &rule7},-	{11836, 4, &rule2},-	{11840, 1, &rule7},-	{11841, 1, &rule2},-	{11842, 1, &rule4},-	{11843, 13, &rule2},-	{11856, 2, &rule13},-	{11858, 3, &rule2},-	{11861, 1, &rule4},-	{11862, 1, &rule5},-	{11863, 1, &rule4},-	{11864, 1, &rule5},-	{11865, 1, &rule4},-	{11866, 1, &rule5},-	{11867, 1, &rule4},-	{11868, 1, &rule5},-	{11869, 1, &rule7},-	{11904, 26, &rule13},-	{11931, 89, &rule13},-	{12032, 214, &rule13},-	{12272, 12, &rule13},-	{12288, 1, &rule1},-	{12289, 3, &rule2},-	{12292, 1, &rule13},-	{12293, 1, &rule91},-	{12294, 1, &rule14},-	{12295, 1, &rule128},-	{12296, 1, &rule4},-	{12297, 1, &rule5},-	{12298, 1, &rule4},-	{12299, 1, &rule5},-	{12300, 1, &rule4},-	{12301, 1, &rule5},-	{12302, 1, &rule4},-	{12303, 1, &rule5},-	{12304, 1, &rule4},-	{12305, 1, &rule5},-	{12306, 2, &rule13},-	{12308, 1, &rule4},-	{12309, 1, &rule5},-	{12310, 1, &rule4},-	{12311, 1, &rule5},-	{12312, 1, &rule4},-	{12313, 1, &rule5},-	{12314, 1, &rule4},-	{12315, 1, &rule5},-	{12316, 1, &rule7},-	{12317, 1, &rule4},-	{12318, 2, &rule5},-	{12320, 1, &rule13},-	{12321, 9, &rule128},-	{12330, 4, &rule92},-	{12334, 2, &rule124},-	{12336, 1, &rule7},-	{12337, 5, &rule91},-	{12342, 2, &rule13},-	{12344, 3, &rule128},-	{12347, 1, &rule91},-	{12348, 1, &rule14},-	{12349, 1, &rule2},-	{12350, 2, &rule13},-	{12353, 86, &rule14},-	{12441, 2, &rule92},-	{12443, 2, &rule10},-	{12445, 2, &rule91},-	{12447, 1, &rule14},-	{12448, 1, &rule7},-	{12449, 90, &rule14},-	{12539, 1, &rule2},-	{12540, 3, &rule91},-	{12543, 1, &rule14},-	{12549, 43, &rule14},-	{12593, 94, &rule14},-	{12688, 2, &rule13},-	{12690, 4, &rule17},-	{12694, 10, &rule13},-	{12704, 32, &rule14},-	{12736, 36, &rule13},-	{12784, 16, &rule14},-	{12800, 31, &rule13},-	{12832, 10, &rule17},-	{12842, 30, &rule13},-	{12872, 8, &rule17},-	{12880, 1, &rule13},-	{12881, 15, &rule17},-	{12896, 32, &rule13},-	{12928, 10, &rule17},-	{12938, 39, &rule13},-	{12977, 15, &rule17},-	{12992, 320, &rule13},-	{13312, 6592, &rule14},-	{19904, 64, &rule13},-	{19968, 21013, &rule14},-	{40981, 1, &rule91},-	{40982, 1143, &rule14},-	{42128, 55, &rule13},-	{42192, 40, &rule14},-	{42232, 6, &rule91},-	{42238, 2, &rule2},-	{42240, 268, &rule14},-	{42508, 1, &rule91},-	{42509, 3, &rule2},-	{42512, 16, &rule14},-	{42528, 10, &rule8},-	{42538, 2, &rule14},-	{42560, 1, &rule22},-	{42561, 1, &rule23},-	{42562, 1, &rule22},-	{42563, 1, &rule23},-	{42564, 1, &rule22},-	{42565, 1, &rule23},-	{42566, 1, &rule22},-	{42567, 1, &rule23},-	{42568, 1, &rule22},-	{42569, 1, &rule23},-	{42570, 1, &rule22},-	{42571, 1, &rule23},-	{42572, 1, &rule22},-	{42573, 1, &rule23},-	{42574, 1, &rule22},-	{42575, 1, &rule23},-	{42576, 1, &rule22},-	{42577, 1, &rule23},-	{42578, 1, &rule22},-	{42579, 1, &rule23},-	{42580, 1, &rule22},-	{42581, 1, &rule23},-	{42582, 1, &rule22},-	{42583, 1, &rule23},-	{42584, 1, &rule22},-	{42585, 1, &rule23},-	{42586, 1, &rule22},-	{42587, 1, &rule23},-	{42588, 1, &rule22},-	{42589, 1, &rule23},-	{42590, 1, &rule22},-	{42591, 1, &rule23},-	{42592, 1, &rule22},-	{42593, 1, &rule23},-	{42594, 1, &rule22},-	{42595, 1, &rule23},-	{42596, 1, &rule22},-	{42597, 1, &rule23},-	{42598, 1, &rule22},-	{42599, 1, &rule23},-	{42600, 1, &rule22},-	{42601, 1, &rule23},-	{42602, 1, &rule22},-	{42603, 1, &rule23},-	{42604, 1, &rule22},-	{42605, 1, &rule23},-	{42606, 1, &rule14},-	{42607, 1, &rule92},-	{42608, 3, &rule119},-	{42611, 1, &rule2},-	{42612, 10, &rule92},-	{42622, 1, &rule2},-	{42623, 1, &rule91},-	{42624, 1, &rule22},-	{42625, 1, &rule23},-	{42626, 1, &rule22},-	{42627, 1, &rule23},-	{42628, 1, &rule22},-	{42629, 1, &rule23},-	{42630, 1, &rule22},-	{42631, 1, &rule23},-	{42632, 1, &rule22},-	{42633, 1, &rule23},-	{42634, 1, &rule22},-	{42635, 1, &rule23},-	{42636, 1, &rule22},-	{42637, 1, &rule23},-	{42638, 1, &rule22},-	{42639, 1, &rule23},-	{42640, 1, &rule22},-	{42641, 1, &rule23},-	{42642, 1, &rule22},-	{42643, 1, &rule23},-	{42644, 1, &rule22},-	{42645, 1, &rule23},-	{42646, 1, &rule22},-	{42647, 1, &rule23},-	{42648, 1, &rule22},-	{42649, 1, &rule23},-	{42650, 1, &rule22},-	{42651, 1, &rule23},-	{42652, 2, &rule91},-	{42654, 2, &rule92},-	{42656, 70, &rule14},-	{42726, 10, &rule128},-	{42736, 2, &rule92},-	{42738, 6, &rule2},-	{42752, 23, &rule10},-	{42775, 9, &rule91},-	{42784, 2, &rule10},-	{42786, 1, &rule22},-	{42787, 1, &rule23},-	{42788, 1, &rule22},-	{42789, 1, &rule23},-	{42790, 1, &rule22},-	{42791, 1, &rule23},-	{42792, 1, &rule22},-	{42793, 1, &rule23},-	{42794, 1, &rule22},-	{42795, 1, &rule23},-	{42796, 1, &rule22},-	{42797, 1, &rule23},-	{42798, 1, &rule22},-	{42799, 1, &rule23},-	{42800, 2, &rule20},-	{42802, 1, &rule22},-	{42803, 1, &rule23},-	{42804, 1, &rule22},-	{42805, 1, &rule23},-	{42806, 1, &rule22},-	{42807, 1, &rule23},-	{42808, 1, &rule22},-	{42809, 1, &rule23},-	{42810, 1, &rule22},-	{42811, 1, &rule23},-	{42812, 1, &rule22},-	{42813, 1, &rule23},-	{42814, 1, &rule22},-	{42815, 1, &rule23},-	{42816, 1, &rule22},-	{42817, 1, &rule23},-	{42818, 1, &rule22},-	{42819, 1, &rule23},-	{42820, 1, &rule22},-	{42821, 1, &rule23},-	{42822, 1, &rule22},-	{42823, 1, &rule23},-	{42824, 1, &rule22},-	{42825, 1, &rule23},-	{42826, 1, &rule22},-	{42827, 1, &rule23},-	{42828, 1, &rule22},-	{42829, 1, &rule23},-	{42830, 1, &rule22},-	{42831, 1, &rule23},-	{42832, 1, &rule22},-	{42833, 1, &rule23},-	{42834, 1, &rule22},-	{42835, 1, &rule23},-	{42836, 1, &rule22},-	{42837, 1, &rule23},-	{42838, 1, &rule22},-	{42839, 1, &rule23},-	{42840, 1, &rule22},-	{42841, 1, &rule23},-	{42842, 1, &rule22},-	{42843, 1, &rule23},-	{42844, 1, &rule22},-	{42845, 1, &rule23},-	{42846, 1, &rule22},-	{42847, 1, &rule23},-	{42848, 1, &rule22},-	{42849, 1, &rule23},-	{42850, 1, &rule22},-	{42851, 1, &rule23},-	{42852, 1, &rule22},-	{42853, 1, &rule23},-	{42854, 1, &rule22},-	{42855, 1, &rule23},-	{42856, 1, &rule22},-	{42857, 1, &rule23},-	{42858, 1, &rule22},-	{42859, 1, &rule23},-	{42860, 1, &rule22},-	{42861, 1, &rule23},-	{42862, 1, &rule22},-	{42863, 1, &rule23},-	{42864, 1, &rule91},-	{42865, 8, &rule20},-	{42873, 1, &rule22},-	{42874, 1, &rule23},-	{42875, 1, &rule22},-	{42876, 1, &rule23},-	{42877, 1, &rule183},-	{42878, 1, &rule22},-	{42879, 1, &rule23},-	{42880, 1, &rule22},-	{42881, 1, &rule23},-	{42882, 1, &rule22},-	{42883, 1, &rule23},-	{42884, 1, &rule22},-	{42885, 1, &rule23},-	{42886, 1, &rule22},-	{42887, 1, &rule23},-	{42888, 1, &rule91},-	{42889, 2, &rule10},-	{42891, 1, &rule22},-	{42892, 1, &rule23},-	{42893, 1, &rule184},-	{42894, 1, &rule20},-	{42895, 1, &rule14},-	{42896, 1, &rule22},-	{42897, 1, &rule23},-	{42898, 1, &rule22},-	{42899, 1, &rule23},-	{42900, 1, &rule185},-	{42901, 1, &rule20},-	{42902, 1, &rule22},-	{42903, 1, &rule23},-	{42904, 1, &rule22},-	{42905, 1, &rule23},-	{42906, 1, &rule22},-	{42907, 1, &rule23},-	{42908, 1, &rule22},-	{42909, 1, &rule23},-	{42910, 1, &rule22},-	{42911, 1, &rule23},-	{42912, 1, &rule22},-	{42913, 1, &rule23},-	{42914, 1, &rule22},-	{42915, 1, &rule23},-	{42916, 1, &rule22},-	{42917, 1, &rule23},-	{42918, 1, &rule22},-	{42919, 1, &rule23},-	{42920, 1, &rule22},-	{42921, 1, &rule23},-	{42922, 1, &rule186},-	{42923, 1, &rule187},-	{42924, 1, &rule188},-	{42925, 1, &rule189},-	{42926, 1, &rule186},-	{42927, 1, &rule20},-	{42928, 1, &rule190},-	{42929, 1, &rule191},-	{42930, 1, &rule192},-	{42931, 1, &rule193},-	{42932, 1, &rule22},-	{42933, 1, &rule23},-	{42934, 1, &rule22},-	{42935, 1, &rule23},-	{42936, 1, &rule22},-	{42937, 1, &rule23},-	{42938, 1, &rule22},-	{42939, 1, &rule23},-	{42940, 1, &rule22},-	{42941, 1, &rule23},-	{42942, 1, &rule22},-	{42943, 1, &rule23},-	{42944, 1, &rule22},-	{42945, 1, &rule23},-	{42946, 1, &rule22},-	{42947, 1, &rule23},-	{42948, 1, &rule194},-	{42949, 1, &rule195},-	{42950, 1, &rule196},-	{42951, 1, &rule22},-	{42952, 1, &rule23},-	{42953, 1, &rule22},-	{42954, 1, &rule23},-	{42960, 1, &rule22},-	{42961, 1, &rule23},-	{42963, 1, &rule20},-	{42965, 1, &rule20},-	{42966, 1, &rule22},-	{42967, 1, &rule23},-	{42968, 1, &rule22},-	{42969, 1, &rule23},-	{42994, 3, &rule91},-	{42997, 1, &rule22},-	{42998, 1, &rule23},-	{42999, 1, &rule14},-	{43000, 2, &rule91},-	{43002, 1, &rule20},-	{43003, 7, &rule14},-	{43010, 1, &rule92},-	{43011, 3, &rule14},-	{43014, 1, &rule92},-	{43015, 4, &rule14},-	{43019, 1, &rule92},-	{43020, 23, &rule14},-	{43043, 2, &rule124},-	{43045, 2, &rule92},-	{43047, 1, &rule124},-	{43048, 4, &rule13},-	{43052, 1, &rule92},-	{43056, 6, &rule17},-	{43062, 2, &rule13},-	{43064, 1, &rule3},-	{43065, 1, &rule13},-	{43072, 52, &rule14},-	{43124, 4, &rule2},-	{43136, 2, &rule124},-	{43138, 50, &rule14},-	{43188, 16, &rule124},-	{43204, 2, &rule92},-	{43214, 2, &rule2},-	{43216, 10, &rule8},-	{43232, 18, &rule92},-	{43250, 6, &rule14},-	{43256, 3, &rule2},-	{43259, 1, &rule14},-	{43260, 1, &rule2},-	{43261, 2, &rule14},-	{43263, 1, &rule92},-	{43264, 10, &rule8},-	{43274, 28, &rule14},-	{43302, 8, &rule92},-	{43310, 2, &rule2},-	{43312, 23, &rule14},-	{43335, 11, &rule92},-	{43346, 2, &rule124},-	{43359, 1, &rule2},-	{43360, 29, &rule14},-	{43392, 3, &rule92},-	{43395, 1, &rule124},-	{43396, 47, &rule14},-	{43443, 1, &rule92},-	{43444, 2, &rule124},-	{43446, 4, &rule92},-	{43450, 2, &rule124},-	{43452, 2, &rule92},-	{43454, 3, &rule124},-	{43457, 13, &rule2},-	{43471, 1, &rule91},-	{43472, 10, &rule8},-	{43486, 2, &rule2},-	{43488, 5, &rule14},-	{43493, 1, &rule92},-	{43494, 1, &rule91},-	{43495, 9, &rule14},-	{43504, 10, &rule8},-	{43514, 5, &rule14},-	{43520, 41, &rule14},-	{43561, 6, &rule92},-	{43567, 2, &rule124},-	{43569, 2, &rule92},-	{43571, 2, &rule124},-	{43573, 2, &rule92},-	{43584, 3, &rule14},-	{43587, 1, &rule92},-	{43588, 8, &rule14},-	{43596, 1, &rule92},-	{43597, 1, &rule124},-	{43600, 10, &rule8},-	{43612, 4, &rule2},-	{43616, 16, &rule14},-	{43632, 1, &rule91},-	{43633, 6, &rule14},-	{43639, 3, &rule13},-	{43642, 1, &rule14},-	{43643, 1, &rule124},-	{43644, 1, &rule92},-	{43645, 1, &rule124},-	{43646, 50, &rule14},-	{43696, 1, &rule92},-	{43697, 1, &rule14},-	{43698, 3, &rule92},-	{43701, 2, &rule14},-	{43703, 2, &rule92},-	{43705, 5, &rule14},-	{43710, 2, &rule92},-	{43712, 1, &rule14},-	{43713, 1, &rule92},-	{43714, 1, &rule14},-	{43739, 2, &rule14},-	{43741, 1, &rule91},-	{43742, 2, &rule2},-	{43744, 11, &rule14},-	{43755, 1, &rule124},-	{43756, 2, &rule92},-	{43758, 2, &rule124},-	{43760, 2, &rule2},-	{43762, 1, &rule14},-	{43763, 2, &rule91},-	{43765, 1, &rule124},-	{43766, 1, &rule92},-	{43777, 6, &rule14},-	{43785, 6, &rule14},-	{43793, 6, &rule14},-	{43808, 7, &rule14},-	{43816, 7, &rule14},-	{43824, 35, &rule20},-	{43859, 1, &rule197},-	{43860, 7, &rule20},-	{43867, 1, &rule10},-	{43868, 4, &rule91},-	{43872, 9, &rule20},-	{43881, 1, &rule91},-	{43882, 2, &rule10},-	{43888, 80, &rule198},-	{43968, 35, &rule14},-	{44003, 2, &rule124},-	{44005, 1, &rule92},-	{44006, 2, &rule124},-	{44008, 1, &rule92},-	{44009, 2, &rule124},-	{44011, 1, &rule2},-	{44012, 1, &rule124},-	{44013, 1, &rule92},-	{44016, 10, &rule8},-	{44032, 11172, &rule14},-	{55216, 23, &rule14},-	{55243, 49, &rule14},-	{55296, 896, &rule199},-	{56192, 128, &rule199},-	{56320, 1024, &rule199},-	{57344, 6400, &rule200},-	{63744, 366, &rule14},-	{64112, 106, &rule14},-	{64256, 7, &rule20},-	{64275, 5, &rule20},-	{64285, 1, &rule14},-	{64286, 1, &rule92},-	{64287, 10, &rule14},-	{64297, 1, &rule6},-	{64298, 13, &rule14},-	{64312, 5, &rule14},-	{64318, 1, &rule14},-	{64320, 2, &rule14},-	{64323, 2, &rule14},-	{64326, 108, &rule14},-	{64434, 17, &rule10},-	{64467, 363, &rule14},-	{64830, 1, &rule5},-	{64831, 1, &rule4},-	{64832, 16, &rule13},-	{64848, 64, &rule14},-	{64914, 54, &rule14},-	{64975, 1, &rule13},-	{65008, 12, &rule14},-	{65020, 1, &rule3},-	{65021, 3, &rule13},-	{65024, 16, &rule92},-	{65040, 7, &rule2},-	{65047, 1, &rule4},-	{65048, 1, &rule5},-	{65049, 1, &rule2},-	{65056, 16, &rule92},-	{65072, 1, &rule2},-	{65073, 2, &rule7},-	{65075, 2, &rule11},-	{65077, 1, &rule4},-	{65078, 1, &rule5},-	{65079, 1, &rule4},-	{65080, 1, &rule5},-	{65081, 1, &rule4},-	{65082, 1, &rule5},-	{65083, 1, &rule4},-	{65084, 1, &rule5},-	{65085, 1, &rule4},-	{65086, 1, &rule5},-	{65087, 1, &rule4},-	{65088, 1, &rule5},-	{65089, 1, &rule4},-	{65090, 1, &rule5},-	{65091, 1, &rule4},-	{65092, 1, &rule5},-	{65093, 2, &rule2},-	{65095, 1, &rule4},-	{65096, 1, &rule5},-	{65097, 4, &rule2},-	{65101, 3, &rule11},-	{65104, 3, &rule2},-	{65108, 4, &rule2},-	{65112, 1, &rule7},-	{65113, 1, &rule4},-	{65114, 1, &rule5},-	{65115, 1, &rule4},-	{65116, 1, &rule5},-	{65117, 1, &rule4},-	{65118, 1, &rule5},-	{65119, 3, &rule2},-	{65122, 1, &rule6},-	{65123, 1, &rule7},-	{65124, 3, &rule6},-	{65128, 1, &rule2},-	{65129, 1, &rule3},-	{65130, 2, &rule2},-	{65136, 5, &rule14},-	{65142, 135, &rule14},-	{65279, 1, &rule16},-	{65281, 3, &rule2},-	{65284, 1, &rule3},-	{65285, 3, &rule2},-	{65288, 1, &rule4},-	{65289, 1, &rule5},-	{65290, 1, &rule2},-	{65291, 1, &rule6},-	{65292, 1, &rule2},-	{65293, 1, &rule7},-	{65294, 2, &rule2},-	{65296, 10, &rule8},-	{65306, 2, &rule2},-	{65308, 3, &rule6},-	{65311, 2, &rule2},-	{65313, 26, &rule9},-	{65339, 1, &rule4},-	{65340, 1, &rule2},-	{65341, 1, &rule5},-	{65342, 1, &rule10},-	{65343, 1, &rule11},-	{65344, 1, &rule10},-	{65345, 26, &rule12},-	{65371, 1, &rule4},-	{65372, 1, &rule6},-	{65373, 1, &rule5},-	{65374, 1, &rule6},-	{65375, 1, &rule4},-	{65376, 1, &rule5},-	{65377, 1, &rule2},-	{65378, 1, &rule4},-	{65379, 1, &rule5},-	{65380, 2, &rule2},-	{65382, 10, &rule14},-	{65392, 1, &rule91},-	{65393, 45, &rule14},-	{65438, 2, &rule91},-	{65440, 31, &rule14},-	{65474, 6, &rule14},-	{65482, 6, &rule14},-	{65490, 6, &rule14},-	{65498, 3, &rule14},-	{65504, 2, &rule3},-	{65506, 1, &rule6},-	{65507, 1, &rule10},-	{65508, 1, &rule13},-	{65509, 2, &rule3},-	{65512, 1, &rule13},-	{65513, 4, &rule6},-	{65517, 2, &rule13},-	{65529, 3, &rule16},-	{65532, 2, &rule13},-	{65536, 12, &rule14},-	{65549, 26, &rule14},-	{65576, 19, &rule14},-	{65596, 2, &rule14},-	{65599, 15, &rule14},-	{65616, 14, &rule14},-	{65664, 123, &rule14},-	{65792, 3, &rule2},-	{65799, 45, &rule17},-	{65847, 9, &rule13},-	{65856, 53, &rule128},-	{65909, 4, &rule17},-	{65913, 17, &rule13},-	{65930, 2, &rule17},-	{65932, 3, &rule13},-	{65936, 13, &rule13},-	{65952, 1, &rule13},-	{66000, 45, &rule13},-	{66045, 1, &rule92},-	{66176, 29, &rule14},-	{66208, 49, &rule14},-	{66272, 1, &rule92},-	{66273, 27, &rule17},-	{66304, 32, &rule14},-	{66336, 4, &rule17},-	{66349, 20, &rule14},-	{66369, 1, &rule128},-	{66370, 8, &rule14},-	{66378, 1, &rule128},-	{66384, 38, &rule14},-	{66422, 5, &rule92},-	{66432, 30, &rule14},-	{66463, 1, &rule2},-	{66464, 36, &rule14},-	{66504, 8, &rule14},-	{66512, 1, &rule2},-	{66513, 5, &rule128},-	{66560, 40, &rule201},-	{66600, 40, &rule202},-	{66640, 78, &rule14},-	{66720, 10, &rule8},-	{66736, 36, &rule201},-	{66776, 36, &rule202},-	{66816, 40, &rule14},-	{66864, 52, &rule14},-	{66927, 1, &rule2},-	{66928, 11, &rule203},-	{66940, 15, &rule203},-	{66956, 7, &rule203},-	{66964, 2, &rule203},-	{66967, 11, &rule204},-	{66979, 15, &rule204},-	{66995, 7, &rule204},-	{67003, 2, &rule204},-	{67072, 311, &rule14},-	{67392, 22, &rule14},-	{67424, 8, &rule14},-	{67456, 6, &rule91},-	{67463, 42, &rule91},-	{67506, 9, &rule91},-	{67584, 6, &rule14},-	{67592, 1, &rule14},-	{67594, 44, &rule14},-	{67639, 2, &rule14},-	{67644, 1, &rule14},-	{67647, 23, &rule14},-	{67671, 1, &rule2},-	{67672, 8, &rule17},-	{67680, 23, &rule14},-	{67703, 2, &rule13},-	{67705, 7, &rule17},-	{67712, 31, &rule14},-	{67751, 9, &rule17},-	{67808, 19, &rule14},-	{67828, 2, &rule14},-	{67835, 5, &rule17},-	{67840, 22, &rule14},-	{67862, 6, &rule17},-	{67871, 1, &rule2},-	{67872, 26, &rule14},-	{67903, 1, &rule2},-	{67968, 56, &rule14},-	{68028, 2, &rule17},-	{68030, 2, &rule14},-	{68032, 16, &rule17},-	{68050, 46, &rule17},-	{68096, 1, &rule14},-	{68097, 3, &rule92},-	{68101, 2, &rule92},-	{68108, 4, &rule92},-	{68112, 4, &rule14},-	{68117, 3, &rule14},-	{68121, 29, &rule14},-	{68152, 3, &rule92},-	{68159, 1, &rule92},-	{68160, 9, &rule17},-	{68176, 9, &rule2},-	{68192, 29, &rule14},-	{68221, 2, &rule17},-	{68223, 1, &rule2},-	{68224, 29, &rule14},-	{68253, 3, &rule17},-	{68288, 8, &rule14},-	{68296, 1, &rule13},-	{68297, 28, &rule14},-	{68325, 2, &rule92},-	{68331, 5, &rule17},-	{68336, 7, &rule2},-	{68352, 54, &rule14},-	{68409, 7, &rule2},-	{68416, 22, &rule14},-	{68440, 8, &rule17},-	{68448, 19, &rule14},-	{68472, 8, &rule17},-	{68480, 18, &rule14},-	{68505, 4, &rule2},-	{68521, 7, &rule17},-	{68608, 73, &rule14},-	{68736, 51, &rule97},-	{68800, 51, &rule102},-	{68858, 6, &rule17},-	{68864, 36, &rule14},-	{68900, 4, &rule92},-	{68912, 10, &rule8},-	{69216, 31, &rule17},-	{69248, 42, &rule14},-	{69291, 2, &rule92},-	{69293, 1, &rule7},-	{69296, 2, &rule14},-	{69376, 29, &rule14},-	{69405, 10, &rule17},-	{69415, 1, &rule14},-	{69424, 22, &rule14},-	{69446, 11, &rule92},-	{69457, 4, &rule17},-	{69461, 5, &rule2},-	{69488, 18, &rule14},-	{69506, 4, &rule92},-	{69510, 4, &rule2},-	{69552, 21, &rule14},-	{69573, 7, &rule17},-	{69600, 23, &rule14},-	{69632, 1, &rule124},-	{69633, 1, &rule92},-	{69634, 1, &rule124},-	{69635, 53, &rule14},-	{69688, 15, &rule92},-	{69703, 7, &rule2},-	{69714, 20, &rule17},-	{69734, 10, &rule8},-	{69744, 1, &rule92},-	{69745, 2, &rule14},-	{69747, 2, &rule92},-	{69749, 1, &rule14},-	{69759, 3, &rule92},-	{69762, 1, &rule124},-	{69763, 45, &rule14},-	{69808, 3, &rule124},-	{69811, 4, &rule92},-	{69815, 2, &rule124},-	{69817, 2, &rule92},-	{69819, 2, &rule2},-	{69821, 1, &rule16},-	{69822, 4, &rule2},-	{69826, 1, &rule92},-	{69837, 1, &rule16},-	{69840, 25, &rule14},-	{69872, 10, &rule8},-	{69888, 3, &rule92},-	{69891, 36, &rule14},-	{69927, 5, &rule92},-	{69932, 1, &rule124},-	{69933, 8, &rule92},-	{69942, 10, &rule8},-	{69952, 4, &rule2},-	{69956, 1, &rule14},-	{69957, 2, &rule124},-	{69959, 1, &rule14},-	{69968, 35, &rule14},-	{70003, 1, &rule92},-	{70004, 2, &rule2},-	{70006, 1, &rule14},-	{70016, 2, &rule92},-	{70018, 1, &rule124},-	{70019, 48, &rule14},-	{70067, 3, &rule124},-	{70070, 9, &rule92},-	{70079, 2, &rule124},-	{70081, 4, &rule14},-	{70085, 4, &rule2},-	{70089, 4, &rule92},-	{70093, 1, &rule2},-	{70094, 1, &rule124},-	{70095, 1, &rule92},-	{70096, 10, &rule8},-	{70106, 1, &rule14},-	{70107, 1, &rule2},-	{70108, 1, &rule14},-	{70109, 3, &rule2},-	{70113, 20, &rule17},-	{70144, 18, &rule14},-	{70163, 25, &rule14},-	{70188, 3, &rule124},-	{70191, 3, &rule92},-	{70194, 2, &rule124},-	{70196, 1, &rule92},-	{70197, 1, &rule124},-	{70198, 2, &rule92},-	{70200, 6, &rule2},-	{70206, 1, &rule92},-	{70272, 7, &rule14},-	{70280, 1, &rule14},-	{70282, 4, &rule14},-	{70287, 15, &rule14},-	{70303, 10, &rule14},-	{70313, 1, &rule2},-	{70320, 47, &rule14},-	{70367, 1, &rule92},-	{70368, 3, &rule124},-	{70371, 8, &rule92},-	{70384, 10, &rule8},-	{70400, 2, &rule92},-	{70402, 2, &rule124},-	{70405, 8, &rule14},-	{70415, 2, &rule14},-	{70419, 22, &rule14},-	{70442, 7, &rule14},-	{70450, 2, &rule14},-	{70453, 5, &rule14},-	{70459, 2, &rule92},-	{70461, 1, &rule14},-	{70462, 2, &rule124},-	{70464, 1, &rule92},-	{70465, 4, &rule124},-	{70471, 2, &rule124},-	{70475, 3, &rule124},-	{70480, 1, &rule14},-	{70487, 1, &rule124},-	{70493, 5, &rule14},-	{70498, 2, &rule124},-	{70502, 7, &rule92},-	{70512, 5, &rule92},-	{70656, 53, &rule14},-	{70709, 3, &rule124},-	{70712, 8, &rule92},-	{70720, 2, &rule124},-	{70722, 3, &rule92},-	{70725, 1, &rule124},-	{70726, 1, &rule92},-	{70727, 4, &rule14},-	{70731, 5, &rule2},-	{70736, 10, &rule8},-	{70746, 2, &rule2},-	{70749, 1, &rule2},-	{70750, 1, &rule92},-	{70751, 3, &rule14},-	{70784, 48, &rule14},-	{70832, 3, &rule124},-	{70835, 6, &rule92},-	{70841, 1, &rule124},-	{70842, 1, &rule92},-	{70843, 4, &rule124},-	{70847, 2, &rule92},-	{70849, 1, &rule124},-	{70850, 2, &rule92},-	{70852, 2, &rule14},-	{70854, 1, &rule2},-	{70855, 1, &rule14},-	{70864, 10, &rule8},-	{71040, 47, &rule14},-	{71087, 3, &rule124},-	{71090, 4, &rule92},-	{71096, 4, &rule124},-	{71100, 2, &rule92},-	{71102, 1, &rule124},-	{71103, 2, &rule92},-	{71105, 23, &rule2},-	{71128, 4, &rule14},-	{71132, 2, &rule92},-	{71168, 48, &rule14},-	{71216, 3, &rule124},-	{71219, 8, &rule92},-	{71227, 2, &rule124},-	{71229, 1, &rule92},-	{71230, 1, &rule124},-	{71231, 2, &rule92},-	{71233, 3, &rule2},-	{71236, 1, &rule14},-	{71248, 10, &rule8},-	{71264, 13, &rule2},-	{71296, 43, &rule14},-	{71339, 1, &rule92},-	{71340, 1, &rule124},-	{71341, 1, &rule92},-	{71342, 2, &rule124},-	{71344, 6, &rule92},-	{71350, 1, &rule124},-	{71351, 1, &rule92},-	{71352, 1, &rule14},-	{71353, 1, &rule2},-	{71360, 10, &rule8},-	{71424, 27, &rule14},-	{71453, 3, &rule92},-	{71456, 2, &rule124},-	{71458, 4, &rule92},-	{71462, 1, &rule124},-	{71463, 5, &rule92},-	{71472, 10, &rule8},-	{71482, 2, &rule17},-	{71484, 3, &rule2},-	{71487, 1, &rule13},-	{71488, 7, &rule14},-	{71680, 44, &rule14},-	{71724, 3, &rule124},-	{71727, 9, &rule92},-	{71736, 1, &rule124},-	{71737, 2, &rule92},-	{71739, 1, &rule2},-	{71840, 32, &rule9},-	{71872, 32, &rule12},-	{71904, 10, &rule8},-	{71914, 9, &rule17},-	{71935, 8, &rule14},-	{71945, 1, &rule14},-	{71948, 8, &rule14},-	{71957, 2, &rule14},-	{71960, 24, &rule14},-	{71984, 6, &rule124},-	{71991, 2, &rule124},-	{71995, 2, &rule92},-	{71997, 1, &rule124},-	{71998, 1, &rule92},-	{71999, 1, &rule14},-	{72000, 1, &rule124},-	{72001, 1, &rule14},-	{72002, 1, &rule124},-	{72003, 1, &rule92},-	{72004, 3, &rule2},-	{72016, 10, &rule8},-	{72096, 8, &rule14},-	{72106, 39, &rule14},-	{72145, 3, &rule124},-	{72148, 4, &rule92},-	{72154, 2, &rule92},-	{72156, 4, &rule124},-	{72160, 1, &rule92},-	{72161, 1, &rule14},-	{72162, 1, &rule2},-	{72163, 1, &rule14},-	{72164, 1, &rule124},-	{72192, 1, &rule14},-	{72193, 10, &rule92},-	{72203, 40, &rule14},-	{72243, 6, &rule92},-	{72249, 1, &rule124},-	{72250, 1, &rule14},-	{72251, 4, &rule92},-	{72255, 8, &rule2},-	{72263, 1, &rule92},-	{72272, 1, &rule14},-	{72273, 6, &rule92},-	{72279, 2, &rule124},-	{72281, 3, &rule92},-	{72284, 46, &rule14},-	{72330, 13, &rule92},-	{72343, 1, &rule124},-	{72344, 2, &rule92},-	{72346, 3, &rule2},-	{72349, 1, &rule14},-	{72350, 5, &rule2},-	{72368, 73, &rule14},-	{72704, 9, &rule14},-	{72714, 37, &rule14},-	{72751, 1, &rule124},-	{72752, 7, &rule92},-	{72760, 6, &rule92},-	{72766, 1, &rule124},-	{72767, 1, &rule92},-	{72768, 1, &rule14},-	{72769, 5, &rule2},-	{72784, 10, &rule8},-	{72794, 19, &rule17},-	{72816, 2, &rule2},-	{72818, 30, &rule14},-	{72850, 22, &rule92},-	{72873, 1, &rule124},-	{72874, 7, &rule92},-	{72881, 1, &rule124},-	{72882, 2, &rule92},-	{72884, 1, &rule124},-	{72885, 2, &rule92},-	{72960, 7, &rule14},-	{72968, 2, &rule14},-	{72971, 38, &rule14},-	{73009, 6, &rule92},-	{73018, 1, &rule92},-	{73020, 2, &rule92},-	{73023, 7, &rule92},-	{73030, 1, &rule14},-	{73031, 1, &rule92},-	{73040, 10, &rule8},-	{73056, 6, &rule14},-	{73063, 2, &rule14},-	{73066, 32, &rule14},-	{73098, 5, &rule124},-	{73104, 2, &rule92},-	{73107, 2, &rule124},-	{73109, 1, &rule92},-	{73110, 1, &rule124},-	{73111, 1, &rule92},-	{73112, 1, &rule14},-	{73120, 10, &rule8},-	{73440, 19, &rule14},-	{73459, 2, &rule92},-	{73461, 2, &rule124},-	{73463, 2, &rule2},-	{73648, 1, &rule14},-	{73664, 21, &rule17},-	{73685, 8, &rule13},-	{73693, 4, &rule3},-	{73697, 17, &rule13},-	{73727, 1, &rule2},-	{73728, 922, &rule14},-	{74752, 111, &rule128},-	{74864, 5, &rule2},-	{74880, 196, &rule14},-	{77712, 97, &rule14},-	{77809, 2, &rule2},-	{77824, 1071, &rule14},-	{78896, 9, &rule16},-	{82944, 583, &rule14},-	{92160, 569, &rule14},-	{92736, 31, &rule14},-	{92768, 10, &rule8},-	{92782, 2, &rule2},-	{92784, 79, &rule14},-	{92864, 10, &rule8},-	{92880, 30, &rule14},-	{92912, 5, &rule92},-	{92917, 1, &rule2},-	{92928, 48, &rule14},-	{92976, 7, &rule92},-	{92983, 5, &rule2},-	{92988, 4, &rule13},-	{92992, 4, &rule91},-	{92996, 1, &rule2},-	{92997, 1, &rule13},-	{93008, 10, &rule8},-	{93019, 7, &rule17},-	{93027, 21, &rule14},-	{93053, 19, &rule14},-	{93760, 32, &rule9},-	{93792, 32, &rule12},-	{93824, 23, &rule17},-	{93847, 4, &rule2},-	{93952, 75, &rule14},-	{94031, 1, &rule92},-	{94032, 1, &rule14},-	{94033, 55, &rule124},-	{94095, 4, &rule92},-	{94099, 13, &rule91},-	{94176, 2, &rule91},-	{94178, 1, &rule2},-	{94179, 1, &rule91},-	{94180, 1, &rule92},-	{94192, 2, &rule124},-	{94208, 6136, &rule14},-	{100352, 1238, &rule14},-	{101632, 9, &rule14},-	{110576, 4, &rule91},-	{110581, 7, &rule91},-	{110589, 2, &rule91},-	{110592, 291, &rule14},-	{110928, 3, &rule14},-	{110948, 4, &rule14},-	{110960, 396, &rule14},-	{113664, 107, &rule14},-	{113776, 13, &rule14},-	{113792, 9, &rule14},-	{113808, 10, &rule14},-	{113820, 1, &rule13},-	{113821, 2, &rule92},-	{113823, 1, &rule2},-	{113824, 4, &rule16},-	{118528, 46, &rule92},-	{118576, 23, &rule92},-	{118608, 116, &rule13},-	{118784, 246, &rule13},-	{119040, 39, &rule13},-	{119081, 60, &rule13},-	{119141, 2, &rule124},-	{119143, 3, &rule92},-	{119146, 3, &rule13},-	{119149, 6, &rule124},-	{119155, 8, &rule16},-	{119163, 8, &rule92},-	{119171, 2, &rule13},-	{119173, 7, &rule92},-	{119180, 30, &rule13},-	{119210, 4, &rule92},-	{119214, 61, &rule13},-	{119296, 66, &rule13},-	{119362, 3, &rule92},-	{119365, 1, &rule13},-	{119520, 20, &rule17},-	{119552, 87, &rule13},-	{119648, 25, &rule17},-	{119808, 26, &rule107},-	{119834, 26, &rule20},-	{119860, 26, &rule107},-	{119886, 7, &rule20},-	{119894, 18, &rule20},-	{119912, 26, &rule107},-	{119938, 26, &rule20},-	{119964, 1, &rule107},-	{119966, 2, &rule107},-	{119970, 1, &rule107},-	{119973, 2, &rule107},-	{119977, 4, &rule107},-	{119982, 8, &rule107},-	{119990, 4, &rule20},-	{119995, 1, &rule20},-	{119997, 7, &rule20},-	{120005, 11, &rule20},-	{120016, 26, &rule107},-	{120042, 26, &rule20},-	{120068, 2, &rule107},-	{120071, 4, &rule107},-	{120077, 8, &rule107},-	{120086, 7, &rule107},-	{120094, 26, &rule20},-	{120120, 2, &rule107},-	{120123, 4, &rule107},-	{120128, 5, &rule107},-	{120134, 1, &rule107},-	{120138, 7, &rule107},-	{120146, 26, &rule20},-	{120172, 26, &rule107},-	{120198, 26, &rule20},-	{120224, 26, &rule107},-	{120250, 26, &rule20},-	{120276, 26, &rule107},-	{120302, 26, &rule20},-	{120328, 26, &rule107},-	{120354, 26, &rule20},-	{120380, 26, &rule107},-	{120406, 26, &rule20},-	{120432, 26, &rule107},-	{120458, 28, &rule20},-	{120488, 25, &rule107},-	{120513, 1, &rule6},-	{120514, 25, &rule20},-	{120539, 1, &rule6},-	{120540, 6, &rule20},-	{120546, 25, &rule107},-	{120571, 1, &rule6},-	{120572, 25, &rule20},-	{120597, 1, &rule6},-	{120598, 6, &rule20},-	{120604, 25, &rule107},-	{120629, 1, &rule6},-	{120630, 25, &rule20},-	{120655, 1, &rule6},-	{120656, 6, &rule20},-	{120662, 25, &rule107},-	{120687, 1, &rule6},-	{120688, 25, &rule20},-	{120713, 1, &rule6},-	{120714, 6, &rule20},-	{120720, 25, &rule107},-	{120745, 1, &rule6},-	{120746, 25, &rule20},-	{120771, 1, &rule6},-	{120772, 6, &rule20},-	{120778, 1, &rule107},-	{120779, 1, &rule20},-	{120782, 50, &rule8},-	{120832, 512, &rule13},-	{121344, 55, &rule92},-	{121399, 4, &rule13},-	{121403, 50, &rule92},-	{121453, 8, &rule13},-	{121461, 1, &rule92},-	{121462, 14, &rule13},-	{121476, 1, &rule92},-	{121477, 2, &rule13},-	{121479, 5, &rule2},-	{121499, 5, &rule92},-	{121505, 15, &rule92},-	{122624, 10, &rule20},-	{122634, 1, &rule14},-	{122635, 20, &rule20},-	{122880, 7, &rule92},-	{122888, 17, &rule92},-	{122907, 7, &rule92},-	{122915, 2, &rule92},-	{122918, 5, &rule92},-	{123136, 45, &rule14},-	{123184, 7, &rule92},-	{123191, 7, &rule91},-	{123200, 10, &rule8},-	{123214, 1, &rule14},-	{123215, 1, &rule13},-	{123536, 30, &rule14},-	{123566, 1, &rule92},-	{123584, 44, &rule14},-	{123628, 4, &rule92},-	{123632, 10, &rule8},-	{123647, 1, &rule3},-	{124896, 7, &rule14},-	{124904, 4, &rule14},-	{124909, 2, &rule14},-	{124912, 15, &rule14},-	{124928, 197, &rule14},-	{125127, 9, &rule17},-	{125136, 7, &rule92},-	{125184, 34, &rule205},-	{125218, 34, &rule206},-	{125252, 7, &rule92},-	{125259, 1, &rule91},-	{125264, 10, &rule8},-	{125278, 2, &rule2},-	{126065, 59, &rule17},-	{126124, 1, &rule13},-	{126125, 3, &rule17},-	{126128, 1, &rule3},-	{126129, 4, &rule17},-	{126209, 45, &rule17},-	{126254, 1, &rule13},-	{126255, 15, &rule17},-	{126464, 4, &rule14},-	{126469, 27, &rule14},-	{126497, 2, &rule14},-	{126500, 1, &rule14},-	{126503, 1, &rule14},-	{126505, 10, &rule14},-	{126516, 4, &rule14},-	{126521, 1, &rule14},-	{126523, 1, &rule14},-	{126530, 1, &rule14},-	{126535, 1, &rule14},-	{126537, 1, &rule14},-	{126539, 1, &rule14},-	{126541, 3, &rule14},-	{126545, 2, &rule14},-	{126548, 1, &rule14},-	{126551, 1, &rule14},-	{126553, 1, &rule14},-	{126555, 1, &rule14},-	{126557, 1, &rule14},-	{126559, 1, &rule14},-	{126561, 2, &rule14},-	{126564, 1, &rule14},-	{126567, 4, &rule14},-	{126572, 7, &rule14},-	{126580, 4, &rule14},-	{126585, 4, &rule14},-	{126590, 1, &rule14},-	{126592, 10, &rule14},-	{126603, 17, &rule14},-	{126625, 3, &rule14},-	{126629, 5, &rule14},-	{126635, 17, &rule14},-	{126704, 2, &rule6},-	{126976, 44, &rule13},-	{127024, 100, &rule13},-	{127136, 15, &rule13},-	{127153, 15, &rule13},-	{127169, 15, &rule13},-	{127185, 37, &rule13},-	{127232, 13, &rule17},-	{127245, 161, &rule13},-	{127462, 29, &rule13},-	{127504, 44, &rule13},-	{127552, 9, &rule13},-	{127568, 2, &rule13},-	{127584, 6, &rule13},-	{127744, 251, &rule13},-	{127995, 5, &rule10},-	{128000, 728, &rule13},-	{128733, 16, &rule13},-	{128752, 13, &rule13},-	{128768, 116, &rule13},-	{128896, 89, &rule13},-	{128992, 12, &rule13},-	{129008, 1, &rule13},-	{129024, 12, &rule13},-	{129040, 56, &rule13},-	{129104, 10, &rule13},-	{129120, 40, &rule13},-	{129168, 30, &rule13},-	{129200, 2, &rule13},-	{129280, 340, &rule13},-	{129632, 14, &rule13},-	{129648, 5, &rule13},-	{129656, 5, &rule13},-	{129664, 7, &rule13},-	{129680, 29, &rule13},-	{129712, 11, &rule13},-	{129728, 6, &rule13},-	{129744, 10, &rule13},-	{129760, 8, &rule13},-	{129776, 7, &rule13},-	{129792, 147, &rule13},-	{129940, 55, &rule13},-	{130032, 10, &rule8},-	{131072, 42720, &rule14},-	{173824, 4153, &rule14},-	{177984, 222, &rule14},-	{178208, 5762, &rule14},-	{183984, 7473, &rule14},-	{194560, 542, &rule14},-	{196608, 4939, &rule14},-	{917505, 1, &rule16},-	{917536, 96, &rule16},-	{917760, 240, &rule92},-	{983040, 65534, &rule200},-	{1048576, 65534, &rule200}-};-static const struct _charblock_ convchars[]={-	{65, 26, &rule9},-	{97, 26, &rule12},-	{181, 1, &rule18},-	{192, 23, &rule9},-	{216, 7, &rule9},-	{224, 23, &rule12},-	{248, 7, &rule12},-	{255, 1, &rule21},-	{256, 1, &rule22},-	{257, 1, &rule23},-	{258, 1, &rule22},-	{259, 1, &rule23},-	{260, 1, &rule22},-	{261, 1, &rule23},-	{262, 1, &rule22},-	{263, 1, &rule23},-	{264, 1, &rule22},-	{265, 1, &rule23},-	{266, 1, &rule22},-	{267, 1, &rule23},-	{268, 1, &rule22},-	{269, 1, &rule23},-	{270, 1, &rule22},-	{271, 1, &rule23},-	{272, 1, &rule22},-	{273, 1, &rule23},-	{274, 1, &rule22},-	{275, 1, &rule23},-	{276, 1, &rule22},-	{277, 1, &rule23},-	{278, 1, &rule22},-	{279, 1, &rule23},-	{280, 1, &rule22},-	{281, 1, &rule23},-	{282, 1, &rule22},-	{283, 1, &rule23},-	{284, 1, &rule22},-	{285, 1, &rule23},-	{286, 1, &rule22},-	{287, 1, &rule23},-	{288, 1, &rule22},-	{289, 1, &rule23},-	{290, 1, &rule22},-	{291, 1, &rule23},-	{292, 1, &rule22},-	{293, 1, &rule23},-	{294, 1, &rule22},-	{295, 1, &rule23},-	{296, 1, &rule22},-	{297, 1, &rule23},-	{298, 1, &rule22},-	{299, 1, &rule23},-	{300, 1, &rule22},-	{301, 1, &rule23},-	{302, 1, &rule22},-	{303, 1, &rule23},-	{304, 1, &rule24},-	{305, 1, &rule25},-	{306, 1, &rule22},-	{307, 1, &rule23},-	{308, 1, &rule22},-	{309, 1, &rule23},-	{310, 1, &rule22},-	{311, 1, &rule23},-	{313, 1, &rule22},-	{314, 1, &rule23},-	{315, 1, &rule22},-	{316, 1, &rule23},-	{317, 1, &rule22},-	{318, 1, &rule23},-	{319, 1, &rule22},-	{320, 1, &rule23},-	{321, 1, &rule22},-	{322, 1, &rule23},-	{323, 1, &rule22},-	{324, 1, &rule23},-	{325, 1, &rule22},-	{326, 1, &rule23},-	{327, 1, &rule22},-	{328, 1, &rule23},-	{330, 1, &rule22},-	{331, 1, &rule23},-	{332, 1, &rule22},-	{333, 1, &rule23},-	{334, 1, &rule22},-	{335, 1, &rule23},-	{336, 1, &rule22},-	{337, 1, &rule23},-	{338, 1, &rule22},-	{339, 1, &rule23},-	{340, 1, &rule22},-	{341, 1, &rule23},-	{342, 1, &rule22},-	{343, 1, &rule23},-	{344, 1, &rule22},-	{345, 1, &rule23},-	{346, 1, &rule22},-	{347, 1, &rule23},-	{348, 1, &rule22},-	{349, 1, &rule23},-	{350, 1, &rule22},-	{351, 1, &rule23},-	{352, 1, &rule22},-	{353, 1, &rule23},-	{354, 1, &rule22},-	{355, 1, &rule23},-	{356, 1, &rule22},-	{357, 1, &rule23},-	{358, 1, &rule22},-	{359, 1, &rule23},-	{360, 1, &rule22},-	{361, 1, &rule23},-	{362, 1, &rule22},-	{363, 1, &rule23},-	{364, 1, &rule22},-	{365, 1, &rule23},-	{366, 1, &rule22},-	{367, 1, &rule23},-	{368, 1, &rule22},-	{369, 1, &rule23},-	{370, 1, &rule22},-	{371, 1, &rule23},-	{372, 1, &rule22},-	{373, 1, &rule23},-	{374, 1, &rule22},-	{375, 1, &rule23},-	{376, 1, &rule26},-	{377, 1, &rule22},-	{378, 1, &rule23},-	{379, 1, &rule22},-	{380, 1, &rule23},-	{381, 1, &rule22},-	{382, 1, &rule23},-	{383, 1, &rule27},-	{384, 1, &rule28},-	{385, 1, &rule29},-	{386, 1, &rule22},-	{387, 1, &rule23},-	{388, 1, &rule22},-	{389, 1, &rule23},-	{390, 1, &rule30},-	{391, 1, &rule22},-	{392, 1, &rule23},-	{393, 2, &rule31},-	{395, 1, &rule22},-	{396, 1, &rule23},-	{398, 1, &rule32},-	{399, 1, &rule33},-	{400, 1, &rule34},-	{401, 1, &rule22},-	{402, 1, &rule23},-	{403, 1, &rule31},-	{404, 1, &rule35},-	{405, 1, &rule36},-	{406, 1, &rule37},-	{407, 1, &rule38},-	{408, 1, &rule22},-	{409, 1, &rule23},-	{410, 1, &rule39},-	{412, 1, &rule37},-	{413, 1, &rule40},-	{414, 1, &rule41},-	{415, 1, &rule42},-	{416, 1, &rule22},-	{417, 1, &rule23},-	{418, 1, &rule22},-	{419, 1, &rule23},-	{420, 1, &rule22},-	{421, 1, &rule23},-	{422, 1, &rule43},-	{423, 1, &rule22},-	{424, 1, &rule23},-	{425, 1, &rule43},-	{428, 1, &rule22},-	{429, 1, &rule23},-	{430, 1, &rule43},-	{431, 1, &rule22},-	{432, 1, &rule23},-	{433, 2, &rule44},-	{435, 1, &rule22},-	{436, 1, &rule23},-	{437, 1, &rule22},-	{438, 1, &rule23},-	{439, 1, &rule45},-	{440, 1, &rule22},-	{441, 1, &rule23},-	{444, 1, &rule22},-	{445, 1, &rule23},-	{447, 1, &rule46},-	{452, 1, &rule47},-	{453, 1, &rule48},-	{454, 1, &rule49},-	{455, 1, &rule47},-	{456, 1, &rule48},-	{457, 1, &rule49},-	{458, 1, &rule47},-	{459, 1, &rule48},-	{460, 1, &rule49},-	{461, 1, &rule22},-	{462, 1, &rule23},-	{463, 1, &rule22},-	{464, 1, &rule23},-	{465, 1, &rule22},-	{466, 1, &rule23},-	{467, 1, &rule22},-	{468, 1, &rule23},-	{469, 1, &rule22},-	{470, 1, &rule23},-	{471, 1, &rule22},-	{472, 1, &rule23},-	{473, 1, &rule22},-	{474, 1, &rule23},-	{475, 1, &rule22},-	{476, 1, &rule23},-	{477, 1, &rule50},-	{478, 1, &rule22},-	{479, 1, &rule23},-	{480, 1, &rule22},-	{481, 1, &rule23},-	{482, 1, &rule22},-	{483, 1, &rule23},-	{484, 1, &rule22},-	{485, 1, &rule23},-	{486, 1, &rule22},-	{487, 1, &rule23},-	{488, 1, &rule22},-	{489, 1, &rule23},-	{490, 1, &rule22},-	{491, 1, &rule23},-	{492, 1, &rule22},-	{493, 1, &rule23},-	{494, 1, &rule22},-	{495, 1, &rule23},-	{497, 1, &rule47},-	{498, 1, &rule48},-	{499, 1, &rule49},-	{500, 1, &rule22},-	{501, 1, &rule23},-	{502, 1, &rule51},-	{503, 1, &rule52},-	{504, 1, &rule22},-	{505, 1, &rule23},-	{506, 1, &rule22},-	{507, 1, &rule23},-	{508, 1, &rule22},-	{509, 1, &rule23},-	{510, 1, &rule22},-	{511, 1, &rule23},-	{512, 1, &rule22},-	{513, 1, &rule23},-	{514, 1, &rule22},-	{515, 1, &rule23},-	{516, 1, &rule22},-	{517, 1, &rule23},-	{518, 1, &rule22},-	{519, 1, &rule23},-	{520, 1, &rule22},-	{521, 1, &rule23},-	{522, 1, &rule22},-	{523, 1, &rule23},-	{524, 1, &rule22},-	{525, 1, &rule23},-	{526, 1, &rule22},-	{527, 1, &rule23},-	{528, 1, &rule22},-	{529, 1, &rule23},-	{530, 1, &rule22},-	{531, 1, &rule23},-	{532, 1, &rule22},-	{533, 1, &rule23},-	{534, 1, &rule22},-	{535, 1, &rule23},-	{536, 1, &rule22},-	{537, 1, &rule23},-	{538, 1, &rule22},-	{539, 1, &rule23},-	{540, 1, &rule22},-	{541, 1, &rule23},-	{542, 1, &rule22},-	{543, 1, &rule23},-	{544, 1, &rule53},-	{546, 1, &rule22},-	{547, 1, &rule23},-	{548, 1, &rule22},-	{549, 1, &rule23},-	{550, 1, &rule22},-	{551, 1, &rule23},-	{552, 1, &rule22},-	{553, 1, &rule23},-	{554, 1, &rule22},-	{555, 1, &rule23},-	{556, 1, &rule22},-	{557, 1, &rule23},-	{558, 1, &rule22},-	{559, 1, &rule23},-	{560, 1, &rule22},-	{561, 1, &rule23},-	{562, 1, &rule22},-	{563, 1, &rule23},-	{570, 1, &rule54},-	{571, 1, &rule22},-	{572, 1, &rule23},-	{573, 1, &rule55},-	{574, 1, &rule56},-	{575, 2, &rule57},-	{577, 1, &rule22},-	{578, 1, &rule23},-	{579, 1, &rule58},-	{580, 1, &rule59},-	{581, 1, &rule60},-	{582, 1, &rule22},-	{583, 1, &rule23},-	{584, 1, &rule22},-	{585, 1, &rule23},-	{586, 1, &rule22},-	{587, 1, &rule23},-	{588, 1, &rule22},-	{589, 1, &rule23},-	{590, 1, &rule22},-	{591, 1, &rule23},-	{592, 1, &rule61},-	{593, 1, &rule62},-	{594, 1, &rule63},-	{595, 1, &rule64},-	{596, 1, &rule65},-	{598, 2, &rule66},-	{601, 1, &rule67},-	{603, 1, &rule68},-	{604, 1, &rule69},-	{608, 1, &rule66},-	{609, 1, &rule70},-	{611, 1, &rule71},-	{613, 1, &rule72},-	{614, 1, &rule73},-	{616, 1, &rule74},-	{617, 1, &rule75},-	{618, 1, &rule73},-	{619, 1, &rule76},-	{620, 1, &rule77},-	{623, 1, &rule75},-	{625, 1, &rule78},-	{626, 1, &rule79},-	{629, 1, &rule80},-	{637, 1, &rule81},-	{640, 1, &rule82},-	{642, 1, &rule83},-	{643, 1, &rule82},-	{647, 1, &rule84},-	{648, 1, &rule82},-	{649, 1, &rule85},-	{650, 2, &rule86},-	{652, 1, &rule87},-	{658, 1, &rule88},-	{669, 1, &rule89},-	{670, 1, &rule90},-	{837, 1, &rule93},-	{880, 1, &rule22},-	{881, 1, &rule23},-	{882, 1, &rule22},-	{883, 1, &rule23},-	{886, 1, &rule22},-	{887, 1, &rule23},-	{891, 3, &rule41},-	{895, 1, &rule94},-	{902, 1, &rule95},-	{904, 3, &rule96},-	{908, 1, &rule97},-	{910, 2, &rule98},-	{913, 17, &rule9},-	{931, 9, &rule9},-	{940, 1, &rule99},-	{941, 3, &rule100},-	{945, 17, &rule12},-	{962, 1, &rule101},-	{963, 9, &rule12},-	{972, 1, &rule102},-	{973, 2, &rule103},-	{975, 1, &rule104},-	{976, 1, &rule105},-	{977, 1, &rule106},-	{981, 1, &rule108},-	{982, 1, &rule109},-	{983, 1, &rule110},-	{984, 1, &rule22},-	{985, 1, &rule23},-	{986, 1, &rule22},-	{987, 1, &rule23},-	{988, 1, &rule22},-	{989, 1, &rule23},-	{990, 1, &rule22},-	{991, 1, &rule23},-	{992, 1, &rule22},-	{993, 1, &rule23},-	{994, 1, &rule22},-	{995, 1, &rule23},-	{996, 1, &rule22},-	{997, 1, &rule23},-	{998, 1, &rule22},-	{999, 1, &rule23},-	{1000, 1, &rule22},-	{1001, 1, &rule23},-	{1002, 1, &rule22},-	{1003, 1, &rule23},-	{1004, 1, &rule22},-	{1005, 1, &rule23},-	{1006, 1, &rule22},-	{1007, 1, &rule23},-	{1008, 1, &rule111},-	{1009, 1, &rule112},-	{1010, 1, &rule113},-	{1011, 1, &rule114},-	{1012, 1, &rule115},-	{1013, 1, &rule116},-	{1015, 1, &rule22},-	{1016, 1, &rule23},-	{1017, 1, &rule117},-	{1018, 1, &rule22},-	{1019, 1, &rule23},-	{1021, 3, &rule53},-	{1024, 16, &rule118},-	{1040, 32, &rule9},-	{1072, 32, &rule12},-	{1104, 16, &rule112},-	{1120, 1, &rule22},-	{1121, 1, &rule23},-	{1122, 1, &rule22},-	{1123, 1, &rule23},-	{1124, 1, &rule22},-	{1125, 1, &rule23},-	{1126, 1, &rule22},-	{1127, 1, &rule23},-	{1128, 1, &rule22},-	{1129, 1, &rule23},-	{1130, 1, &rule22},-	{1131, 1, &rule23},-	{1132, 1, &rule22},-	{1133, 1, &rule23},-	{1134, 1, &rule22},-	{1135, 1, &rule23},-	{1136, 1, &rule22},-	{1137, 1, &rule23},-	{1138, 1, &rule22},-	{1139, 1, &rule23},-	{1140, 1, &rule22},-	{1141, 1, &rule23},-	{1142, 1, &rule22},-	{1143, 1, &rule23},-	{1144, 1, &rule22},-	{1145, 1, &rule23},-	{1146, 1, &rule22},-	{1147, 1, &rule23},-	{1148, 1, &rule22},-	{1149, 1, &rule23},-	{1150, 1, &rule22},-	{1151, 1, &rule23},-	{1152, 1, &rule22},-	{1153, 1, &rule23},-	{1162, 1, &rule22},-	{1163, 1, &rule23},-	{1164, 1, &rule22},-	{1165, 1, &rule23},-	{1166, 1, &rule22},-	{1167, 1, &rule23},-	{1168, 1, &rule22},-	{1169, 1, &rule23},-	{1170, 1, &rule22},-	{1171, 1, &rule23},-	{1172, 1, &rule22},-	{1173, 1, &rule23},-	{1174, 1, &rule22},-	{1175, 1, &rule23},-	{1176, 1, &rule22},-	{1177, 1, &rule23},-	{1178, 1, &rule22},-	{1179, 1, &rule23},-	{1180, 1, &rule22},-	{1181, 1, &rule23},-	{1182, 1, &rule22},-	{1183, 1, &rule23},-	{1184, 1, &rule22},-	{1185, 1, &rule23},-	{1186, 1, &rule22},-	{1187, 1, &rule23},-	{1188, 1, &rule22},-	{1189, 1, &rule23},-	{1190, 1, &rule22},-	{1191, 1, &rule23},-	{1192, 1, &rule22},-	{1193, 1, &rule23},-	{1194, 1, &rule22},-	{1195, 1, &rule23},-	{1196, 1, &rule22},-	{1197, 1, &rule23},-	{1198, 1, &rule22},-	{1199, 1, &rule23},-	{1200, 1, &rule22},-	{1201, 1, &rule23},-	{1202, 1, &rule22},-	{1203, 1, &rule23},-	{1204, 1, &rule22},-	{1205, 1, &rule23},-	{1206, 1, &rule22},-	{1207, 1, &rule23},-	{1208, 1, &rule22},-	{1209, 1, &rule23},-	{1210, 1, &rule22},-	{1211, 1, &rule23},-	{1212, 1, &rule22},-	{1213, 1, &rule23},-	{1214, 1, &rule22},-	{1215, 1, &rule23},-	{1216, 1, &rule120},-	{1217, 1, &rule22},-	{1218, 1, &rule23},-	{1219, 1, &rule22},-	{1220, 1, &rule23},-	{1221, 1, &rule22},-	{1222, 1, &rule23},-	{1223, 1, &rule22},-	{1224, 1, &rule23},-	{1225, 1, &rule22},-	{1226, 1, &rule23},-	{1227, 1, &rule22},-	{1228, 1, &rule23},-	{1229, 1, &rule22},-	{1230, 1, &rule23},-	{1231, 1, &rule121},-	{1232, 1, &rule22},-	{1233, 1, &rule23},-	{1234, 1, &rule22},-	{1235, 1, &rule23},-	{1236, 1, &rule22},-	{1237, 1, &rule23},-	{1238, 1, &rule22},-	{1239, 1, &rule23},-	{1240, 1, &rule22},-	{1241, 1, &rule23},-	{1242, 1, &rule22},-	{1243, 1, &rule23},-	{1244, 1, &rule22},-	{1245, 1, &rule23},-	{1246, 1, &rule22},-	{1247, 1, &rule23},-	{1248, 1, &rule22},-	{1249, 1, &rule23},-	{1250, 1, &rule22},-	{1251, 1, &rule23},-	{1252, 1, &rule22},-	{1253, 1, &rule23},-	{1254, 1, &rule22},-	{1255, 1, &rule23},-	{1256, 1, &rule22},-	{1257, 1, &rule23},-	{1258, 1, &rule22},-	{1259, 1, &rule23},-	{1260, 1, &rule22},-	{1261, 1, &rule23},-	{1262, 1, &rule22},-	{1263, 1, &rule23},-	{1264, 1, &rule22},-	{1265, 1, &rule23},-	{1266, 1, &rule22},-	{1267, 1, &rule23},-	{1268, 1, &rule22},-	{1269, 1, &rule23},-	{1270, 1, &rule22},-	{1271, 1, &rule23},-	{1272, 1, &rule22},-	{1273, 1, &rule23},-	{1274, 1, &rule22},-	{1275, 1, &rule23},-	{1276, 1, &rule22},-	{1277, 1, &rule23},-	{1278, 1, &rule22},-	{1279, 1, &rule23},-	{1280, 1, &rule22},-	{1281, 1, &rule23},-	{1282, 1, &rule22},-	{1283, 1, &rule23},-	{1284, 1, &rule22},-	{1285, 1, &rule23},-	{1286, 1, &rule22},-	{1287, 1, &rule23},-	{1288, 1, &rule22},-	{1289, 1, &rule23},-	{1290, 1, &rule22},-	{1291, 1, &rule23},-	{1292, 1, &rule22},-	{1293, 1, &rule23},-	{1294, 1, &rule22},-	{1295, 1, &rule23},-	{1296, 1, &rule22},-	{1297, 1, &rule23},-	{1298, 1, &rule22},-	{1299, 1, &rule23},-	{1300, 1, &rule22},-	{1301, 1, &rule23},-	{1302, 1, &rule22},-	{1303, 1, &rule23},-	{1304, 1, &rule22},-	{1305, 1, &rule23},-	{1306, 1, &rule22},-	{1307, 1, &rule23},-	{1308, 1, &rule22},-	{1309, 1, &rule23},-	{1310, 1, &rule22},-	{1311, 1, &rule23},-	{1312, 1, &rule22},-	{1313, 1, &rule23},-	{1314, 1, &rule22},-	{1315, 1, &rule23},-	{1316, 1, &rule22},-	{1317, 1, &rule23},-	{1318, 1, &rule22},-	{1319, 1, &rule23},-	{1320, 1, &rule22},-	{1321, 1, &rule23},-	{1322, 1, &rule22},-	{1323, 1, &rule23},-	{1324, 1, &rule22},-	{1325, 1, &rule23},-	{1326, 1, &rule22},-	{1327, 1, &rule23},-	{1329, 38, &rule122},-	{1377, 38, &rule123},-	{4256, 38, &rule125},-	{4295, 1, &rule125},-	{4301, 1, &rule125},-	{4304, 43, &rule126},-	{4349, 3, &rule126},-	{5024, 80, &rule127},-	{5104, 6, &rule104},-	{5112, 6, &rule110},-	{7296, 1, &rule129},-	{7297, 1, &rule130},-	{7298, 1, &rule131},-	{7299, 2, &rule132},-	{7301, 1, &rule133},-	{7302, 1, &rule134},-	{7303, 1, &rule135},-	{7304, 1, &rule136},-	{7312, 43, &rule137},-	{7357, 3, &rule137},-	{7545, 1, &rule138},-	{7549, 1, &rule139},-	{7566, 1, &rule140},-	{7680, 1, &rule22},-	{7681, 1, &rule23},-	{7682, 1, &rule22},-	{7683, 1, &rule23},-	{7684, 1, &rule22},-	{7685, 1, &rule23},-	{7686, 1, &rule22},-	{7687, 1, &rule23},-	{7688, 1, &rule22},-	{7689, 1, &rule23},-	{7690, 1, &rule22},-	{7691, 1, &rule23},-	{7692, 1, &rule22},-	{7693, 1, &rule23},-	{7694, 1, &rule22},-	{7695, 1, &rule23},-	{7696, 1, &rule22},-	{7697, 1, &rule23},-	{7698, 1, &rule22},-	{7699, 1, &rule23},-	{7700, 1, &rule22},-	{7701, 1, &rule23},-	{7702, 1, &rule22},-	{7703, 1, &rule23},-	{7704, 1, &rule22},-	{7705, 1, &rule23},-	{7706, 1, &rule22},-	{7707, 1, &rule23},-	{7708, 1, &rule22},-	{7709, 1, &rule23},-	{7710, 1, &rule22},-	{7711, 1, &rule23},-	{7712, 1, &rule22},-	{7713, 1, &rule23},-	{7714, 1, &rule22},-	{7715, 1, &rule23},-	{7716, 1, &rule22},-	{7717, 1, &rule23},-	{7718, 1, &rule22},-	{7719, 1, &rule23},-	{7720, 1, &rule22},-	{7721, 1, &rule23},-	{7722, 1, &rule22},-	{7723, 1, &rule23},-	{7724, 1, &rule22},-	{7725, 1, &rule23},-	{7726, 1, &rule22},-	{7727, 1, &rule23},-	{7728, 1, &rule22},-	{7729, 1, &rule23},-	{7730, 1, &rule22},-	{7731, 1, &rule23},-	{7732, 1, &rule22},-	{7733, 1, &rule23},-	{7734, 1, &rule22},-	{7735, 1, &rule23},-	{7736, 1, &rule22},-	{7737, 1, &rule23},-	{7738, 1, &rule22},-	{7739, 1, &rule23},-	{7740, 1, &rule22},-	{7741, 1, &rule23},-	{7742, 1, &rule22},-	{7743, 1, &rule23},-	{7744, 1, &rule22},-	{7745, 1, &rule23},-	{7746, 1, &rule22},-	{7747, 1, &rule23},-	{7748, 1, &rule22},-	{7749, 1, &rule23},-	{7750, 1, &rule22},-	{7751, 1, &rule23},-	{7752, 1, &rule22},-	{7753, 1, &rule23},-	{7754, 1, &rule22},-	{7755, 1, &rule23},-	{7756, 1, &rule22},-	{7757, 1, &rule23},-	{7758, 1, &rule22},-	{7759, 1, &rule23},-	{7760, 1, &rule22},-	{7761, 1, &rule23},-	{7762, 1, &rule22},-	{7763, 1, &rule23},-	{7764, 1, &rule22},-	{7765, 1, &rule23},-	{7766, 1, &rule22},-	{7767, 1, &rule23},-	{7768, 1, &rule22},-	{7769, 1, &rule23},-	{7770, 1, &rule22},-	{7771, 1, &rule23},-	{7772, 1, &rule22},-	{7773, 1, &rule23},-	{7774, 1, &rule22},-	{7775, 1, &rule23},-	{7776, 1, &rule22},-	{7777, 1, &rule23},-	{7778, 1, &rule22},-	{7779, 1, &rule23},-	{7780, 1, &rule22},-	{7781, 1, &rule23},-	{7782, 1, &rule22},-	{7783, 1, &rule23},-	{7784, 1, &rule22},-	{7785, 1, &rule23},-	{7786, 1, &rule22},-	{7787, 1, &rule23},-	{7788, 1, &rule22},-	{7789, 1, &rule23},-	{7790, 1, &rule22},-	{7791, 1, &rule23},-	{7792, 1, &rule22},-	{7793, 1, &rule23},-	{7794, 1, &rule22},-	{7795, 1, &rule23},-	{7796, 1, &rule22},-	{7797, 1, &rule23},-	{7798, 1, &rule22},-	{7799, 1, &rule23},-	{7800, 1, &rule22},-	{7801, 1, &rule23},-	{7802, 1, &rule22},-	{7803, 1, &rule23},-	{7804, 1, &rule22},-	{7805, 1, &rule23},-	{7806, 1, &rule22},-	{7807, 1, &rule23},-	{7808, 1, &rule22},-	{7809, 1, &rule23},-	{7810, 1, &rule22},-	{7811, 1, &rule23},-	{7812, 1, &rule22},-	{7813, 1, &rule23},-	{7814, 1, &rule22},-	{7815, 1, &rule23},-	{7816, 1, &rule22},-	{7817, 1, &rule23},-	{7818, 1, &rule22},-	{7819, 1, &rule23},-	{7820, 1, &rule22},-	{7821, 1, &rule23},-	{7822, 1, &rule22},-	{7823, 1, &rule23},-	{7824, 1, &rule22},-	{7825, 1, &rule23},-	{7826, 1, &rule22},-	{7827, 1, &rule23},-	{7828, 1, &rule22},-	{7829, 1, &rule23},-	{7835, 1, &rule141},-	{7838, 1, &rule142},-	{7840, 1, &rule22},-	{7841, 1, &rule23},-	{7842, 1, &rule22},-	{7843, 1, &rule23},-	{7844, 1, &rule22},-	{7845, 1, &rule23},-	{7846, 1, &rule22},-	{7847, 1, &rule23},-	{7848, 1, &rule22},-	{7849, 1, &rule23},-	{7850, 1, &rule22},-	{7851, 1, &rule23},-	{7852, 1, &rule22},-	{7853, 1, &rule23},-	{7854, 1, &rule22},-	{7855, 1, &rule23},-	{7856, 1, &rule22},-	{7857, 1, &rule23},-	{7858, 1, &rule22},-	{7859, 1, &rule23},-	{7860, 1, &rule22},-	{7861, 1, &rule23},-	{7862, 1, &rule22},-	{7863, 1, &rule23},-	{7864, 1, &rule22},-	{7865, 1, &rule23},-	{7866, 1, &rule22},-	{7867, 1, &rule23},-	{7868, 1, &rule22},-	{7869, 1, &rule23},-	{7870, 1, &rule22},-	{7871, 1, &rule23},-	{7872, 1, &rule22},-	{7873, 1, &rule23},-	{7874, 1, &rule22},-	{7875, 1, &rule23},-	{7876, 1, &rule22},-	{7877, 1, &rule23},-	{7878, 1, &rule22},-	{7879, 1, &rule23},-	{7880, 1, &rule22},-	{7881, 1, &rule23},-	{7882, 1, &rule22},-	{7883, 1, &rule23},-	{7884, 1, &rule22},-	{7885, 1, &rule23},-	{7886, 1, &rule22},-	{7887, 1, &rule23},-	{7888, 1, &rule22},-	{7889, 1, &rule23},-	{7890, 1, &rule22},-	{7891, 1, &rule23},-	{7892, 1, &rule22},-	{7893, 1, &rule23},-	{7894, 1, &rule22},-	{7895, 1, &rule23},-	{7896, 1, &rule22},-	{7897, 1, &rule23},-	{7898, 1, &rule22},-	{7899, 1, &rule23},-	{7900, 1, &rule22},-	{7901, 1, &rule23},-	{7902, 1, &rule22},-	{7903, 1, &rule23},-	{7904, 1, &rule22},-	{7905, 1, &rule23},-	{7906, 1, &rule22},-	{7907, 1, &rule23},-	{7908, 1, &rule22},-	{7909, 1, &rule23},-	{7910, 1, &rule22},-	{7911, 1, &rule23},-	{7912, 1, &rule22},-	{7913, 1, &rule23},-	{7914, 1, &rule22},-	{7915, 1, &rule23},-	{7916, 1, &rule22},-	{7917, 1, &rule23},-	{7918, 1, &rule22},-	{7919, 1, &rule23},-	{7920, 1, &rule22},-	{7921, 1, &rule23},-	{7922, 1, &rule22},-	{7923, 1, &rule23},-	{7924, 1, &rule22},-	{7925, 1, &rule23},-	{7926, 1, &rule22},-	{7927, 1, &rule23},-	{7928, 1, &rule22},-	{7929, 1, &rule23},-	{7930, 1, &rule22},-	{7931, 1, &rule23},-	{7932, 1, &rule22},-	{7933, 1, &rule23},-	{7934, 1, &rule22},-	{7935, 1, &rule23},-	{7936, 8, &rule143},-	{7944, 8, &rule144},-	{7952, 6, &rule143},-	{7960, 6, &rule144},-	{7968, 8, &rule143},-	{7976, 8, &rule144},-	{7984, 8, &rule143},-	{7992, 8, &rule144},-	{8000, 6, &rule143},-	{8008, 6, &rule144},-	{8017, 1, &rule143},-	{8019, 1, &rule143},-	{8021, 1, &rule143},-	{8023, 1, &rule143},-	{8025, 1, &rule144},-	{8027, 1, &rule144},-	{8029, 1, &rule144},-	{8031, 1, &rule144},-	{8032, 8, &rule143},-	{8040, 8, &rule144},-	{8048, 2, &rule145},-	{8050, 4, &rule146},-	{8054, 2, &rule147},-	{8056, 2, &rule148},-	{8058, 2, &rule149},-	{8060, 2, &rule150},-	{8064, 8, &rule143},-	{8072, 8, &rule151},-	{8080, 8, &rule143},-	{8088, 8, &rule151},-	{8096, 8, &rule143},-	{8104, 8, &rule151},-	{8112, 2, &rule143},-	{8115, 1, &rule152},-	{8120, 2, &rule144},-	{8122, 2, &rule153},-	{8124, 1, &rule154},-	{8126, 1, &rule155},-	{8131, 1, &rule152},-	{8136, 4, &rule156},-	{8140, 1, &rule154},-	{8144, 2, &rule143},-	{8152, 2, &rule144},-	{8154, 2, &rule157},-	{8160, 2, &rule143},-	{8165, 1, &rule113},-	{8168, 2, &rule144},-	{8170, 2, &rule158},-	{8172, 1, &rule117},-	{8179, 1, &rule152},-	{8184, 2, &rule159},-	{8186, 2, &rule160},-	{8188, 1, &rule154},-	{8486, 1, &rule163},-	{8490, 1, &rule164},-	{8491, 1, &rule165},-	{8498, 1, &rule166},-	{8526, 1, &rule167},-	{8544, 16, &rule168},-	{8560, 16, &rule169},-	{8579, 1, &rule22},-	{8580, 1, &rule23},-	{9398, 26, &rule170},-	{9424, 26, &rule171},-	{11264, 48, &rule122},-	{11312, 48, &rule123},-	{11360, 1, &rule22},-	{11361, 1, &rule23},-	{11362, 1, &rule172},-	{11363, 1, &rule173},-	{11364, 1, &rule174},-	{11365, 1, &rule175},-	{11366, 1, &rule176},-	{11367, 1, &rule22},-	{11368, 1, &rule23},-	{11369, 1, &rule22},-	{11370, 1, &rule23},-	{11371, 1, &rule22},-	{11372, 1, &rule23},-	{11373, 1, &rule177},-	{11374, 1, &rule178},-	{11375, 1, &rule179},-	{11376, 1, &rule180},-	{11378, 1, &rule22},-	{11379, 1, &rule23},-	{11381, 1, &rule22},-	{11382, 1, &rule23},-	{11390, 2, &rule181},-	{11392, 1, &rule22},-	{11393, 1, &rule23},-	{11394, 1, &rule22},-	{11395, 1, &rule23},-	{11396, 1, &rule22},-	{11397, 1, &rule23},-	{11398, 1, &rule22},-	{11399, 1, &rule23},-	{11400, 1, &rule22},-	{11401, 1, &rule23},-	{11402, 1, &rule22},-	{11403, 1, &rule23},-	{11404, 1, &rule22},-	{11405, 1, &rule23},-	{11406, 1, &rule22},-	{11407, 1, &rule23},-	{11408, 1, &rule22},-	{11409, 1, &rule23},-	{11410, 1, &rule22},-	{11411, 1, &rule23},-	{11412, 1, &rule22},-	{11413, 1, &rule23},-	{11414, 1, &rule22},-	{11415, 1, &rule23},-	{11416, 1, &rule22},-	{11417, 1, &rule23},-	{11418, 1, &rule22},-	{11419, 1, &rule23},-	{11420, 1, &rule22},-	{11421, 1, &rule23},-	{11422, 1, &rule22},-	{11423, 1, &rule23},-	{11424, 1, &rule22},-	{11425, 1, &rule23},-	{11426, 1, &rule22},-	{11427, 1, &rule23},-	{11428, 1, &rule22},-	{11429, 1, &rule23},-	{11430, 1, &rule22},-	{11431, 1, &rule23},-	{11432, 1, &rule22},-	{11433, 1, &rule23},-	{11434, 1, &rule22},-	{11435, 1, &rule23},-	{11436, 1, &rule22},-	{11437, 1, &rule23},-	{11438, 1, &rule22},-	{11439, 1, &rule23},-	{11440, 1, &rule22},-	{11441, 1, &rule23},-	{11442, 1, &rule22},-	{11443, 1, &rule23},-	{11444, 1, &rule22},-	{11445, 1, &rule23},-	{11446, 1, &rule22},-	{11447, 1, &rule23},-	{11448, 1, &rule22},-	{11449, 1, &rule23},-	{11450, 1, &rule22},-	{11451, 1, &rule23},-	{11452, 1, &rule22},-	{11453, 1, &rule23},-	{11454, 1, &rule22},-	{11455, 1, &rule23},-	{11456, 1, &rule22},-	{11457, 1, &rule23},-	{11458, 1, &rule22},-	{11459, 1, &rule23},-	{11460, 1, &rule22},-	{11461, 1, &rule23},-	{11462, 1, &rule22},-	{11463, 1, &rule23},-	{11464, 1, &rule22},-	{11465, 1, &rule23},-	{11466, 1, &rule22},-	{11467, 1, &rule23},-	{11468, 1, &rule22},-	{11469, 1, &rule23},-	{11470, 1, &rule22},-	{11471, 1, &rule23},-	{11472, 1, &rule22},-	{11473, 1, &rule23},-	{11474, 1, &rule22},-	{11475, 1, &rule23},-	{11476, 1, &rule22},-	{11477, 1, &rule23},-	{11478, 1, &rule22},-	{11479, 1, &rule23},-	{11480, 1, &rule22},-	{11481, 1, &rule23},-	{11482, 1, &rule22},-	{11483, 1, &rule23},-	{11484, 1, &rule22},-	{11485, 1, &rule23},-	{11486, 1, &rule22},-	{11487, 1, &rule23},-	{11488, 1, &rule22},-	{11489, 1, &rule23},-	{11490, 1, &rule22},-	{11491, 1, &rule23},-	{11499, 1, &rule22},-	{11500, 1, &rule23},-	{11501, 1, &rule22},-	{11502, 1, &rule23},-	{11506, 1, &rule22},-	{11507, 1, &rule23},-	{11520, 38, &rule182},-	{11559, 1, &rule182},-	{11565, 1, &rule182},-	{42560, 1, &rule22},-	{42561, 1, &rule23},-	{42562, 1, &rule22},-	{42563, 1, &rule23},-	{42564, 1, &rule22},-	{42565, 1, &rule23},-	{42566, 1, &rule22},-	{42567, 1, &rule23},-	{42568, 1, &rule22},-	{42569, 1, &rule23},-	{42570, 1, &rule22},-	{42571, 1, &rule23},-	{42572, 1, &rule22},-	{42573, 1, &rule23},-	{42574, 1, &rule22},-	{42575, 1, &rule23},-	{42576, 1, &rule22},-	{42577, 1, &rule23},-	{42578, 1, &rule22},-	{42579, 1, &rule23},-	{42580, 1, &rule22},-	{42581, 1, &rule23},-	{42582, 1, &rule22},-	{42583, 1, &rule23},-	{42584, 1, &rule22},-	{42585, 1, &rule23},-	{42586, 1, &rule22},-	{42587, 1, &rule23},-	{42588, 1, &rule22},-	{42589, 1, &rule23},-	{42590, 1, &rule22},-	{42591, 1, &rule23},-	{42592, 1, &rule22},-	{42593, 1, &rule23},-	{42594, 1, &rule22},-	{42595, 1, &rule23},-	{42596, 1, &rule22},-	{42597, 1, &rule23},-	{42598, 1, &rule22},-	{42599, 1, &rule23},-	{42600, 1, &rule22},-	{42601, 1, &rule23},-	{42602, 1, &rule22},-	{42603, 1, &rule23},-	{42604, 1, &rule22},-	{42605, 1, &rule23},-	{42624, 1, &rule22},-	{42625, 1, &rule23},-	{42626, 1, &rule22},-	{42627, 1, &rule23},-	{42628, 1, &rule22},-	{42629, 1, &rule23},-	{42630, 1, &rule22},-	{42631, 1, &rule23},-	{42632, 1, &rule22},-	{42633, 1, &rule23},-	{42634, 1, &rule22},-	{42635, 1, &rule23},-	{42636, 1, &rule22},-	{42637, 1, &rule23},-	{42638, 1, &rule22},-	{42639, 1, &rule23},-	{42640, 1, &rule22},-	{42641, 1, &rule23},-	{42642, 1, &rule22},-	{42643, 1, &rule23},-	{42644, 1, &rule22},-	{42645, 1, &rule23},-	{42646, 1, &rule22},-	{42647, 1, &rule23},-	{42648, 1, &rule22},-	{42649, 1, &rule23},-	{42650, 1, &rule22},-	{42651, 1, &rule23},-	{42786, 1, &rule22},-	{42787, 1, &rule23},-	{42788, 1, &rule22},-	{42789, 1, &rule23},-	{42790, 1, &rule22},-	{42791, 1, &rule23},-	{42792, 1, &rule22},-	{42793, 1, &rule23},-	{42794, 1, &rule22},-	{42795, 1, &rule23},-	{42796, 1, &rule22},-	{42797, 1, &rule23},-	{42798, 1, &rule22},-	{42799, 1, &rule23},-	{42802, 1, &rule22},-	{42803, 1, &rule23},-	{42804, 1, &rule22},-	{42805, 1, &rule23},-	{42806, 1, &rule22},-	{42807, 1, &rule23},-	{42808, 1, &rule22},-	{42809, 1, &rule23},-	{42810, 1, &rule22},-	{42811, 1, &rule23},-	{42812, 1, &rule22},-	{42813, 1, &rule23},-	{42814, 1, &rule22},-	{42815, 1, &rule23},-	{42816, 1, &rule22},-	{42817, 1, &rule23},-	{42818, 1, &rule22},-	{42819, 1, &rule23},-	{42820, 1, &rule22},-	{42821, 1, &rule23},-	{42822, 1, &rule22},-	{42823, 1, &rule23},-	{42824, 1, &rule22},-	{42825, 1, &rule23},-	{42826, 1, &rule22},-	{42827, 1, &rule23},-	{42828, 1, &rule22},-	{42829, 1, &rule23},-	{42830, 1, &rule22},-	{42831, 1, &rule23},-	{42832, 1, &rule22},-	{42833, 1, &rule23},-	{42834, 1, &rule22},-	{42835, 1, &rule23},-	{42836, 1, &rule22},-	{42837, 1, &rule23},-	{42838, 1, &rule22},-	{42839, 1, &rule23},-	{42840, 1, &rule22},-	{42841, 1, &rule23},-	{42842, 1, &rule22},-	{42843, 1, &rule23},-	{42844, 1, &rule22},-	{42845, 1, &rule23},-	{42846, 1, &rule22},-	{42847, 1, &rule23},-	{42848, 1, &rule22},-	{42849, 1, &rule23},-	{42850, 1, &rule22},-	{42851, 1, &rule23},-	{42852, 1, &rule22},-	{42853, 1, &rule23},-	{42854, 1, &rule22},-	{42855, 1, &rule23},-	{42856, 1, &rule22},-	{42857, 1, &rule23},-	{42858, 1, &rule22},-	{42859, 1, &rule23},-	{42860, 1, &rule22},-	{42861, 1, &rule23},-	{42862, 1, &rule22},-	{42863, 1, &rule23},-	{42873, 1, &rule22},-	{42874, 1, &rule23},-	{42875, 1, &rule22},-	{42876, 1, &rule23},-	{42877, 1, &rule183},-	{42878, 1, &rule22},-	{42879, 1, &rule23},-	{42880, 1, &rule22},-	{42881, 1, &rule23},-	{42882, 1, &rule22},-	{42883, 1, &rule23},-	{42884, 1, &rule22},-	{42885, 1, &rule23},-	{42886, 1, &rule22},-	{42887, 1, &rule23},-	{42891, 1, &rule22},-	{42892, 1, &rule23},-	{42893, 1, &rule184},-	{42896, 1, &rule22},-	{42897, 1, &rule23},-	{42898, 1, &rule22},-	{42899, 1, &rule23},-	{42900, 1, &rule185},-	{42902, 1, &rule22},-	{42903, 1, &rule23},-	{42904, 1, &rule22},-	{42905, 1, &rule23},-	{42906, 1, &rule22},-	{42907, 1, &rule23},-	{42908, 1, &rule22},-	{42909, 1, &rule23},-	{42910, 1, &rule22},-	{42911, 1, &rule23},-	{42912, 1, &rule22},-	{42913, 1, &rule23},-	{42914, 1, &rule22},-	{42915, 1, &rule23},-	{42916, 1, &rule22},-	{42917, 1, &rule23},-	{42918, 1, &rule22},-	{42919, 1, &rule23},-	{42920, 1, &rule22},-	{42921, 1, &rule23},-	{42922, 1, &rule186},-	{42923, 1, &rule187},-	{42924, 1, &rule188},-	{42925, 1, &rule189},-	{42926, 1, &rule186},-	{42928, 1, &rule190},-	{42929, 1, &rule191},-	{42930, 1, &rule192},-	{42931, 1, &rule193},-	{42932, 1, &rule22},-	{42933, 1, &rule23},-	{42934, 1, &rule22},-	{42935, 1, &rule23},-	{42936, 1, &rule22},-	{42937, 1, &rule23},-	{42938, 1, &rule22},-	{42939, 1, &rule23},-	{42940, 1, &rule22},-	{42941, 1, &rule23},-	{42942, 1, &rule22},-	{42943, 1, &rule23},-	{42944, 1, &rule22},-	{42945, 1, &rule23},-	{42946, 1, &rule22},-	{42947, 1, &rule23},-	{42948, 1, &rule194},-	{42949, 1, &rule195},-	{42950, 1, &rule196},-	{42951, 1, &rule22},-	{42952, 1, &rule23},-	{42953, 1, &rule22},-	{42954, 1, &rule23},-	{42960, 1, &rule22},-	{42961, 1, &rule23},-	{42966, 1, &rule22},-	{42967, 1, &rule23},-	{42968, 1, &rule22},-	{42969, 1, &rule23},-	{42997, 1, &rule22},-	{42998, 1, &rule23},-	{43859, 1, &rule197},-	{43888, 80, &rule198},-	{65313, 26, &rule9},-	{65345, 26, &rule12},-	{66560, 40, &rule201},-	{66600, 40, &rule202},-	{66736, 36, &rule201},-	{66776, 36, &rule202},-	{66928, 11, &rule203},-	{66940, 15, &rule203},-	{66956, 7, &rule203},-	{66964, 2, &rule203},-	{66967, 11, &rule204},-	{66979, 15, &rule204},-	{66995, 7, &rule204},-	{67003, 2, &rule204},-	{68736, 51, &rule97},-	{68800, 51, &rule102},-	{71840, 32, &rule9},-	{71872, 32, &rule12},-	{93760, 32, &rule9},-	{93792, 32, &rule12},-	{125184, 34, &rule205},-	{125218, 34, &rule206}-};-static const struct _charblock_ spacechars[]={-	{32, 1, &rule1},-	{160, 1, &rule1},-	{5760, 1, &rule1},-	{8192, 11, &rule1},-	{8239, 1, &rule1},-	{8287, 1, &rule1},-	{12288, 1, &rule1}-};--/*-	Obtain the reference to character rule by doing-	binary search over the specified array of blocks.-	To make checkattr shorter, the address of-	nullrule is returned if the search fails:-	this rule defines no category and no conversion-	distances. The compare function returns 0 when-	key->start is within the block. Otherwise-	result of comparison of key->start and start of the-	current block is returned as usual.-*/--static const struct _convrule_ nullrule={0,NUMCAT_CN,0,0,0,0};--static int blkcmp(const void *vk,const void *vb)-{-	const struct _charblock_ *key,*cur;-	key=vk;-	cur=vb;-	if((key->start>=cur->start)&&(key->start<(cur->start+cur->length)))-	{-		return 0;-	}-	if(key->start>cur->start) return 1;-	return -1;-}--static const struct _convrule_ *getrule(-	const struct _charblock_ *blocks,-	int numblocks,-	int unichar)-{-	struct _charblock_ key={unichar,1,(void *)0};-	struct _charblock_ *cb=bsearch(&key,blocks,numblocks,sizeof(key),blkcmp);-	if(cb==(void *)0) return &nullrule;-	return cb->rule;-}-	---/*-	Check whether a character (internal code) has certain attributes.-	Attributes (category flags) may be ORed. The function ANDs-	character category flags and the mask and returns the result.-	If the character belongs to one of the categories requested,-	the result will be nonzero.-*/--inline static int checkattr(int c,unsigned int catmask)-{-	return (catmask & (getrule(allchars,(c<256)?NUM_LAT1BLOCKS:NUM_BLOCKS,c)->category));-}--inline static int checkattr_s(int c,unsigned int catmask)-{-        return (catmask & (getrule(spacechars,NUM_SPACEBLOCKS,c)->category));-}--/*-	Define predicate functions for some combinations of categories.-*/--#define unipred(p,m) \-HsInt p(HsInt c) \-{ \-	return checkattr(c,m); \-}--#define unipred_s(p,m) \-HsInt p(HsInt c) \-{ \-        return checkattr_s(c,m); \-}--/*-	Make these rules as close to Hugs as possible.-*/--unipred(u_iswcntrl,GENCAT_CC)-unipred(u_iswprint, (GENCAT_MC | GENCAT_NO | GENCAT_SK | GENCAT_ME | GENCAT_ND |   GENCAT_PO | GENCAT_LT | GENCAT_PC | GENCAT_SM | GENCAT_ZS |   GENCAT_LU | GENCAT_PD | GENCAT_SO | GENCAT_PE | GENCAT_PF |   GENCAT_PS | GENCAT_SC | GENCAT_LL | GENCAT_LM | GENCAT_PI |   GENCAT_NL | GENCAT_MN | GENCAT_LO))-unipred_s(u_iswspace,GENCAT_ZS)-unipred(u_iswupper,(GENCAT_LU|GENCAT_LT))-unipred(u_iswlower,GENCAT_LL)-unipred(u_iswalpha,(GENCAT_LL|GENCAT_LU|GENCAT_LT|GENCAT_LM|GENCAT_LO))-unipred(u_iswdigit,GENCAT_ND)--unipred(u_iswalnum,(GENCAT_LT|GENCAT_LU|GENCAT_LL|GENCAT_LM|GENCAT_LO|-		    GENCAT_NO|GENCAT_ND|GENCAT_NL))--#define caseconv(p,to) \-HsInt p(HsInt c) \-{ \-	const struct _convrule_ *rule=getrule(convchars,NUM_CONVBLOCKS,c);\-	if(rule==&nullrule) return c;\-	return c+rule->to;\-}--caseconv(u_towupper,updist)-caseconv(u_towlower,lowdist)-caseconv(u_towtitle,titledist)--HsInt u_gencat(HsInt c)-{-	return getrule(allchars,NUM_BLOCKS,c)->catnumber;-}
− cbits/Win32Utils.c 
@@ -1,306 +0,0 @@-/* -----------------------------------------------------------------------------   (c) The University of Glasgow 2006--   Useful Win32 bits-   ------------------------------------------------------------------------- */--#if defined(_WIN32)-/* Use Mingw's C99 print functions.  */-#define __USE_MINGW_ANSI_STDIO 1-/* Using Secure APIs */-#define MINGW_HAS_SECURE_API 1--#include "HsBase.h"-#include <stdbool.h>-#include <stdint.h>-#include <wchar.h>-#include <windows.h>-#include <io.h>-#include <objbase.h>-#include <ntstatus.h>-#include <winternl.h>-#include "fs.h"--/* This is the error table that defines the mapping between OS error-   codes and errno values */--struct errentry {-        unsigned long oscode;           /* OS return value */-        int errnocode;  /* System V error code */-};--static struct errentry errtable[] = {-        {  ERROR_INVALID_FUNCTION,       EINVAL    },  /* 1 */-        {  ERROR_FILE_NOT_FOUND,         ENOENT    },  /* 2 */-        {  ERROR_PATH_NOT_FOUND,         ENOENT    },  /* 3 */-        {  ERROR_TOO_MANY_OPEN_FILES,    EMFILE    },  /* 4 */-        {  ERROR_ACCESS_DENIED,          EACCES    },  /* 5 */-        {  ERROR_INVALID_HANDLE,         EBADF     },  /* 6 */-        {  ERROR_ARENA_TRASHED,          ENOMEM    },  /* 7 */-        {  ERROR_NOT_ENOUGH_MEMORY,      ENOMEM    },  /* 8 */-        {  ERROR_INVALID_BLOCK,          ENOMEM    },  /* 9 */-        {  ERROR_BAD_ENVIRONMENT,        E2BIG     },  /* 10 */-        {  ERROR_BAD_FORMAT,             ENOEXEC   },  /* 11 */-        {  ERROR_INVALID_ACCESS,         EINVAL    },  /* 12 */-        {  ERROR_INVALID_DATA,           EINVAL    },  /* 13 */-        {  ERROR_INVALID_DRIVE,          ENOENT    },  /* 15 */-        {  ERROR_CURRENT_DIRECTORY,      EACCES    },  /* 16 */-        {  ERROR_NOT_SAME_DEVICE,        EXDEV     },  /* 17 */-        {  ERROR_NO_MORE_FILES,          ENOENT    },  /* 18 */-        {  ERROR_LOCK_VIOLATION,         EACCES    },  /* 33 */-        {  ERROR_BAD_NETPATH,            ENOENT    },  /* 53 */-        {  ERROR_NETWORK_ACCESS_DENIED,  EACCES    },  /* 65 */-        {  ERROR_BAD_NET_NAME,           ENOENT    },  /* 67 */-        {  ERROR_FILE_EXISTS,            EEXIST    },  /* 80 */-        {  ERROR_CANNOT_MAKE,            EACCES    },  /* 82 */-        {  ERROR_FAIL_I24,               EACCES    },  /* 83 */-        {  ERROR_INVALID_PARAMETER,      EINVAL    },  /* 87 */-        {  ERROR_NO_PROC_SLOTS,          EAGAIN    },  /* 89 */-        {  ERROR_DRIVE_LOCKED,           EACCES    },  /* 108 */-        {  ERROR_BROKEN_PIPE,            EPIPE     },  /* 109 */-        {  ERROR_DISK_FULL,              ENOSPC    },  /* 112 */-        {  ERROR_INVALID_TARGET_HANDLE,  EBADF     },  /* 114 */-        {  ERROR_INVALID_HANDLE,         EINVAL    },  /* 124 */-        {  ERROR_WAIT_NO_CHILDREN,       ECHILD    },  /* 128 */-        {  ERROR_CHILD_NOT_COMPLETE,     ECHILD    },  /* 129 */-        {  ERROR_DIRECT_ACCESS_HANDLE,   EBADF     },  /* 130 */-        {  ERROR_NEGATIVE_SEEK,          EINVAL    },  /* 131 */-        {  ERROR_SEEK_ON_DEVICE,         EACCES    },  /* 132 */-        {  ERROR_DIR_NOT_EMPTY,          ENOTEMPTY },  /* 145 */-        {  ERROR_NOT_LOCKED,             EACCES    },  /* 158 */-        {  ERROR_BAD_PATHNAME,           ENOENT    },  /* 161 */-        {  ERROR_MAX_THRDS_REACHED,      EAGAIN    },  /* 164 */-        {  ERROR_LOCK_FAILED,            EACCES    },  /* 167 */-        {  ERROR_ALREADY_EXISTS,         EEXIST    },  /* 183 */-        {  ERROR_FILENAME_EXCED_RANGE,   ENOENT    },  /* 206 */-        {  ERROR_NESTING_NOT_ALLOWED,    EAGAIN    },  /* 215 */-           /* Windows returns this when the read end of a pipe is-            * closed (or closing) and we write to it. */-        {  ERROR_NO_DATA,                EPIPE     },  /* 232 */-        {  ERROR_NOT_ENOUGH_QUOTA,       ENOMEM    }  /* 1816 */-};--/* size of the table */-#define ERRTABLESIZE (sizeof(errtable)/sizeof(errtable[0]))--/* The following two constants must be the minimum and maximum-   values in the (contiguous) range of Exec Failure errors. */-#define MIN_EXEC_ERROR ERROR_INVALID_STARTING_CODESEG-#define MAX_EXEC_ERROR ERROR_INFLOOP_IN_RELOC_CHAIN--/* These are the low and high value in the range of errors that are-   access violations */-#define MIN_EACCES_RANGE ERROR_WRITE_PROTECT-#define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED--void maperrno(void)-{-    errno = maperrno_func(GetLastError());-}--int maperrno_func(DWORD dwErrorCode)-{-    int i;--    /* check the table for the OS error code */-    for (i = 0; i < ERRTABLESIZE; ++i)-        if (dwErrorCode == errtable[i].oscode)-            return errtable[i].errnocode;--    /* The error code wasn't in the table.  We check for a range of */-    /* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */-    /* EINVAL is returned.                                          */--    if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)-        return EACCES;-    else if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)-        return ENOEXEC;-    else-        return EINVAL;-}--LPWSTR base_getErrorMessage(DWORD err)-{-    LPWSTR what;-    DWORD res;--    res = FormatMessageW(-              (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER),-              NULL,-              err,-              MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */-              (LPWSTR) &what,-              0,-              NULL-          );-    if (res == 0)-        return NULL;-    return what;-}--int get_unique_file_info_hwnd(HANDLE h, HsWord64 *dev, HsWord64 *ino)-{-    BY_HANDLE_FILE_INFORMATION info;--    if (GetFileInformationByHandle(h, &info))-    {-        *dev = info.dwVolumeSerialNumber;-        *ino = info.nFileIndexLow-             | ((HsWord64)info.nFileIndexHigh << 32);--        return 0;-    }--    return -1;-}--int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)-{-    HANDLE h = (HANDLE)_get_osfhandle(fd);-    return get_unique_file_info_hwnd (h, dev, ino);-}--BOOL file_exists(LPCTSTR path)-{-    DWORD r = GetFileAttributes(path);-    return r != INVALID_FILE_ATTRIBUTES;-}--/* If true then caller needs to free tempFileName.  */-bool __createUUIDTempFileErrNo (wchar_t* pathName, wchar_t* prefix,-                                wchar_t* suffix, wchar_t** tempFileName)-{-  *tempFileName = NULL;-  int retry = 5;-  bool success = false;-  while (retry-- > 0 && !success)-    {-      GUID guid;-      ZeroMemory (&guid, sizeof (guid));-      if (CoCreateGuid (&guid) != S_OK)-        goto fail;--      RPC_WSTR guidStr;-      if (UuidToStringW ((UUID*)&guid, &guidStr) != S_OK)-        goto fail;-      /* We can't create a device path here since this path escapes the compiler-         so instead return a normal path and have openFile deal with it.  */-      wchar_t* devName = malloc (sizeof (wchar_t) * (wcslen (pathName) + 1));-      wcscpy (devName, pathName);-      int len = wcslen (devName) + wcslen (suffix) + wcslen (prefix)-              + wcslen (guidStr) + 3;-      *tempFileName = malloc (len * sizeof (wchar_t));-      if (*tempFileName == NULL)-        goto fail;--      /* Only add a slash if path didn't already end in one, otherwise we create-         an invalid path.  */-      bool slashed = devName[wcslen(devName)-1] == '\\';-      wchar_t* sep = slashed ? L"" : L"\\";-      if (-1 == swprintf_s (*tempFileName, len, L"%ls%ls%ls-%ls%ls",-                            devName, sep, prefix, guidStr, suffix))-        goto fail;--      free (devName);-      RpcStringFreeW (&guidStr);--      /* This should never happen because GUIDs are unique.  But in case hell-         froze over let's check anyway.  */-      DWORD dwAttrib = GetFileAttributesW (*tempFileName);-      success = (dwAttrib == INVALID_FILE_ATTRIBUTES-                 || (dwAttrib & FILE_ATTRIBUTE_DIRECTORY));-      if (!success)-        free (*tempFileName);-    }--  return success;--fail:-  if (*tempFileName != NULL) {-    free (*tempFileName);-  }-  maperrno();-  return false;-}---/* Seems to be part of the Windows SDK so provide an inline definition for-   use and rename it so it doesn't conflict for people who do have the SDK.  */--typedef struct _MY_PUBLIC_OBJECT_BASIC_INFORMATION {-  ULONG Attributes;-  ACCESS_MASK GrantedAccess;-  ULONG HandleCount;-  ULONG PointerCount;-  ULONG Reserved[10];- } MY_PUBLIC_OBJECT_BASIC_INFORMATION, *PMY_PUBLIC_OBJECT_BASIC_INFORMATION;--ACCESS_MASK __get_handle_access_mask (HANDLE handle)-{-  MY_PUBLIC_OBJECT_BASIC_INFORMATION obi;-  if (STATUS_SUCCESS != NtQueryObject(handle, ObjectBasicInformation, &obi,-                                      sizeof(obi), NULL))-  {-    return obi.GrantedAccess;-  }--  maperrno();-  return 0;-}--bool getTempFileNameErrorNo (wchar_t* pathName, wchar_t* prefix,-                             wchar_t* suffix, uint32_t uUnique,-                             wchar_t* tempFileName)-{-  int retry = 5;-  bool success = false;-  while (retry > 0 && !success)-    {-      // TODO: This needs to handle long file names.-      if (!GetTempFileNameW(pathName, prefix, uUnique, tempFileName))-        {-          maperrno();-          return false;-        }--      wchar_t* drive = malloc (sizeof(wchar_t) * _MAX_DRIVE);-      wchar_t* dir   = malloc (sizeof(wchar_t) * _MAX_DIR);-      wchar_t* fname = malloc (sizeof(wchar_t) * _MAX_FNAME);-      if (_wsplitpath_s (tempFileName, drive, _MAX_DRIVE, dir, _MAX_DIR,-                        fname, _MAX_FNAME, NULL, 0) != 0)-        {-          success = false;-          maperrno ();-        }-      else-        {-          wchar_t* temp = _wcsdup (tempFileName);-          if (wcsnlen(drive, _MAX_DRIVE) == 0)-            swprintf_s(tempFileName, MAX_PATH, L"%s\%s%s",-                      dir, fname, suffix);-          else-            swprintf_s(tempFileName, MAX_PATH, L"%s\%s\%s%s",-                      drive, dir, fname, suffix);-          success-             = MoveFileExW(temp, tempFileName, MOVEFILE_WRITE_THROUGH-                                               | MOVEFILE_COPY_ALLOWED) != 0;-          errno = 0;-          if (!success && (GetLastError () != ERROR_FILE_EXISTS || --retry < 0))-            {-              success = false;-              maperrno ();-              DeleteFileW (temp);-            }---          free(temp);-        }--      free(drive);-      free(dir);-      free(fname);-    }--  return success;-}-#endif
− cbits/consUtils.c 
@@ -1,89 +0,0 @@-/*- * (c) The University of Glasgow 2002- *- * Win32 Console API support- */-#if defined(_WIN32) || defined(__CYGWIN__)-/* to the end */--#include "consUtils.h"-#include <windows.h>-#include <io.h>--#if defined(__CYGWIN__)-#define _get_osfhandle get_osfhandle-#endif--int is_console__(int fd) {-    DWORD st;-    HANDLE h;-    if (!_isatty(fd)) {-        /* TTY must be a character device */-        return 0;-    }-    h = (HANDLE)_get_osfhandle(fd);-    if (h == INVALID_HANDLE_VALUE) {-        /* Broken handle can't be terminal */-        return 0;-    }-    if (!GetConsoleMode(h, &st)) {-        /* GetConsoleMode appears to fail when it's not a TTY.  In-           particular, it's what most of our terminal functions-           assume works, so if it doesn't work for all intents-           and purposes we're not dealing with a terminal. */-        return 0;-    }-    return 1;-}---int-set_console_buffering__(int fd, int cooked)-{-    HANDLE h;-    DWORD  st;-    /* According to GetConsoleMode() docs, it is not possible to-       leave ECHO_INPUT enabled without also having LINE_INPUT,-       so we have to turn both off here. */-    DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;--    if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {-	if ( GetConsoleMode(h,&st) &&-	     SetConsoleMode(h, cooked ? (st | ENABLE_LINE_INPUT) : st & ~flgs)  ) {-	    return 0;-	}-    }-    return -1;-}--int-set_console_echo__(int fd, int on)-{-    HANDLE h;-    DWORD  st;-    DWORD flgs = ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT;--    if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {-	if ( GetConsoleMode(h,&st) &&-	     SetConsoleMode(h,( on ? (st | flgs) : (st & ~ENABLE_ECHO_INPUT))) ) {-	    return 0;-	}-    }-    return -1;-}--int-get_console_echo__(int fd)-{-    HANDLE h;-    DWORD  st;--    if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {-	if ( GetConsoleMode(h,&st) ) {-	    return (st & ENABLE_ECHO_INPUT ? 1 : 0);-	}-    }-    return -1;-}--#endif /* defined(_WIN32) || ... */
− cbits/fs.c 
@@ -1,590 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) Tamar Christina 2018-2019- *- * Windows I/O routines for file opening.- *- * NOTE: Only modify this file in utils/fs/ and rerun configure. Do not edit- *       this file in any other directory as it will be overwritten.- *- * ---------------------------------------------------------------------------*/-#include "fs.h"-#include <stdio.h>--#if defined(_WIN32)--#include <stdbool.h>-#include <stdlib.h>-#include <stdint.h>--#include <windows.h>-#include <io.h>-#include <fcntl.h>-#include <wchar.h>-#include <share.h>-#include <errno.h>--/* Duplicate a string, but in wide form. The caller is responsible for freeing-   the result. */-static wchar_t* FS(to_wide) (const char *path) {-  size_t len = mbstowcs (NULL, path, 0);-  wchar_t *w_path = malloc (sizeof (wchar_t) * (len + 1));-  mbstowcs (w_path, path, len);-  w_path[len] = L'\0';-  return w_path;-}--/* This function converts Windows paths between namespaces. More specifically-   It converts an explorer style path into a NT or Win32 namespace.-   This has several caveats but they are caveats that are native to Windows and-   not POSIX. See-   https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247.aspx.-   Anything else such as raw device paths we leave untouched.  The main benefit-   of doing any of this is that we can break the MAX_PATH restriction and also-   access raw handles that we couldn't before.--   The resulting string is dynamically allocated and so callers are expected to-   free this string.  */-wchar_t* FS(create_device_name) (const wchar_t* filename) {-  const wchar_t* win32_dev_namespace  = L"\\\\.\\";-  const wchar_t* win32_file_namespace = L"\\\\?\\";-  const wchar_t* nt_device_namespace  = L"\\Device\\";-  const wchar_t* unc_prefix           = L"UNC\\";-  const wchar_t* network_share        = L"\\\\";--  wchar_t* result = _wcsdup (filename);-  wchar_t ns[10] = {0};--  /* If the file is already in a native namespace don't change it.  */-  if (   wcsncmp (win32_dev_namespace , filename, 4) == 0-      || wcsncmp (win32_file_namespace, filename, 4) == 0-      || wcsncmp (nt_device_namespace , filename, 8) == 0)-    return result;--  /* Since we're using the lower level APIs we must normalize slashes now.  The-     Win32 API layer will no longer convert '/' into '\\' for us.  */-  for (size_t i = 0; i < wcslen (result); i++)-    {-      if (result[i] == L'/')-        result[i] = L'\\';-    }--  /* We need to expand dos short paths as well.  */-  DWORD nResult = GetLongPathNameW (result, NULL, 0) + 1;-  wchar_t* temp = NULL;-  if (nResult > 1)-    {-      temp = _wcsdup (result);-      free (result);-      result = malloc (nResult * sizeof (wchar_t));-      if (GetLongPathNameW (temp, result, nResult) == 0)-        {-          result = memcpy (result, temp, wcslen (temp));-          goto cleanup;-        }-      free (temp);-    }--  /* Now resolve any . and .. in the path or subsequent API calls may fail since-     Win32 will no longer resolve them.  */-  nResult = GetFullPathNameW (result, 0, NULL, NULL) + 1;-  temp = _wcsdup (result);-  free (result);-  result = malloc (nResult * sizeof (wchar_t));-  if (GetFullPathNameW (temp, nResult, result, NULL) == 0)-    {-      result = memcpy (result, temp, wcslen (temp));-      goto cleanup;-    }--  free (temp);--  int startOffset = 0;-  /* When remapping a network share, \\foo needs to become-     \\?\UNC\foo and not \\?\\UNC\\foo which is an invalid path.  */-  if (wcsncmp (network_share, result, 2) == 0)-    {-      if (swprintf (ns, 10, L"%ls%ls", win32_file_namespace, unc_prefix) <= 0)-        {-          goto cleanup;-        }-      startOffset = 2;-    }-  else if (swprintf (ns, 10, L"%ls", win32_file_namespace) <= 0)-    {-      goto cleanup;-    }--  /* Create new string.  */-  int bLen = wcslen (result) + wcslen (ns) + 1 - startOffset;-  temp = _wcsdup (result + startOffset);-  free (result);-  result = malloc (bLen * sizeof (wchar_t));-  if (swprintf (result, bLen, L"%ls%ls", ns, temp) <= 0)-    {-      goto cleanup;-    }--  free (temp);--  return result;--cleanup:-  free (temp);-  free (result);-  return NULL;-}--static int setErrNoFromWin32Error (void);-/* Sets errno to the right error value and returns -1 to indicate the failure.-   This function should only be called when the creation of the fd actually-   failed and you want to return -1 for the fd.  */-static-int setErrNoFromWin32Error () {-  switch (GetLastError()) {-    case ERROR_SUCCESS:-      errno = 0;-      break;-    case ERROR_ACCESS_DENIED:-    case ERROR_FILE_READ_ONLY:-      errno = EACCES;-      break;-    case ERROR_FILE_NOT_FOUND:-    case ERROR_PATH_NOT_FOUND:-      errno = ENOENT;-      break;-    case ERROR_FILE_EXISTS:-      errno = EEXIST;-      break;-    case ERROR_NOT_ENOUGH_MEMORY:-    case ERROR_OUTOFMEMORY:-      errno = ENOMEM;-      break;-    case ERROR_INVALID_HANDLE:-      errno = EBADF;-      break;-    case ERROR_INVALID_FUNCTION:-      errno = EFAULT;-      break;-    default:-      errno = EINVAL;-      break;-  }-  return -1;-}---#define HAS_FLAG(a,b) (((a) & (b)) == (b))--int FS(swopen) (const wchar_t* filename, int oflag, int shflag, int pmode)-{-  /* Construct access mode.  */-  /* https://docs.microsoft.com/en-us/windows/win32/fileio/file-access-rights-constants  */-  DWORD dwDesiredAccess = 0;-  if (HAS_FLAG (oflag, _O_RDONLY))-    dwDesiredAccess |= GENERIC_READ;-  if (HAS_FLAG (oflag, _O_RDWR))-    dwDesiredAccess |= GENERIC_WRITE | GENERIC_READ;-  if (HAS_FLAG (oflag, _O_WRONLY))-    dwDesiredAccess |= GENERIC_WRITE;-  if (HAS_FLAG (oflag, _O_APPEND))-    dwDesiredAccess |= FILE_APPEND_DATA;--  /* Construct shared mode.  */-  /* https://docs.microsoft.com/en-us/windows/win32/fileio/file-attribute-constants */-  DWORD dwShareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;-  if (HAS_FLAG (shflag, _SH_DENYRW))-    dwShareMode &= ~(FILE_SHARE_READ | FILE_SHARE_WRITE);-  if (HAS_FLAG (shflag, _SH_DENYWR))-    dwShareMode &= ~FILE_SHARE_WRITE;-  if (HAS_FLAG (shflag, _SH_DENYRD))-    dwShareMode &= ~FILE_SHARE_READ;-  if (HAS_FLAG (pmode, _S_IWRITE))-    dwShareMode |= FILE_SHARE_READ | FILE_SHARE_WRITE;-  if (HAS_FLAG (pmode, _S_IREAD))-    dwShareMode |= FILE_SHARE_READ;--  /* Override access mode with pmode if creating file.  */-  if (HAS_FLAG (oflag, _O_CREAT))-    {-      if (HAS_FLAG (pmode, _S_IWRITE))-        dwDesiredAccess |= FILE_GENERIC_WRITE;-      if (HAS_FLAG (pmode, _S_IREAD))-        dwDesiredAccess |= FILE_GENERIC_READ;-    }--  /* Create file disposition.  */-  /* https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea */-  DWORD dwCreationDisposition = 0;-  if (HAS_FLAG (oflag, (_O_CREAT | _O_EXCL)))-    dwCreationDisposition |= CREATE_NEW;-  else if (HAS_FLAG (oflag, _O_TRUNC | _O_CREAT))-    dwCreationDisposition |= CREATE_ALWAYS;-  else if (HAS_FLAG (oflag, _O_TRUNC) && !HAS_FLAG (oflag, O_RDONLY))-    dwCreationDisposition |= TRUNCATE_EXISTING;-  else if (HAS_FLAG (oflag, _O_APPEND | _O_CREAT))-    dwCreationDisposition |= OPEN_ALWAYS;-  else if (HAS_FLAG (oflag, _O_APPEND))-    dwCreationDisposition |= OPEN_EXISTING;-  else if (HAS_FLAG (oflag, _O_CREAT))-    dwCreationDisposition |= OPEN_ALWAYS;-  else-    dwCreationDisposition |= OPEN_EXISTING;--  /* Set file access attributes.  */-  DWORD dwFlagsAndAttributes = FILE_ATTRIBUTE_NORMAL;-  if (HAS_FLAG (oflag, _O_RDONLY))-    dwFlagsAndAttributes |= 0; /* No special attribute.  */-  if (HAS_FLAG (oflag, _O_TEMPORARY))-    {-      dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;-      dwShareMode |= FILE_SHARE_DELETE;-    }-  if (HAS_FLAG (oflag, _O_SHORT_LIVED))-    dwFlagsAndAttributes |= FILE_ATTRIBUTE_TEMPORARY;-  if (HAS_FLAG (oflag, _O_RANDOM))-    dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS;-  if (HAS_FLAG (oflag, _O_SEQUENTIAL))-    dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN;-  /* Flag is only valid on it's own.  */-  if (dwFlagsAndAttributes != FILE_ATTRIBUTE_NORMAL)-    dwFlagsAndAttributes &= ~FILE_ATTRIBUTE_NORMAL;--  /* Ensure we have shared read for files which are opened read-only. */-  if (HAS_FLAG (dwCreationDisposition, OPEN_EXISTING)-      && ((dwDesiredAccess & (GENERIC_WRITE|GENERIC_READ)) == GENERIC_READ))-    dwShareMode |= FILE_SHARE_READ;--  /* Set security attributes.  */-  SECURITY_ATTRIBUTES securityAttributes;-  ZeroMemory (&securityAttributes, sizeof(SECURITY_ATTRIBUTES));-  securityAttributes.bInheritHandle       = !(oflag & _O_NOINHERIT);-  securityAttributes.lpSecurityDescriptor = NULL;-  securityAttributes.nLength              = sizeof(SECURITY_ATTRIBUTES);--  wchar_t* _filename = FS(create_device_name) (filename);-  if (!_filename)-    return -1;--  HANDLE hResult-    = CreateFileW (_filename, dwDesiredAccess, dwShareMode, &securityAttributes,-                   dwCreationDisposition, dwFlagsAndAttributes, NULL);--  free (_filename);-  if (INVALID_HANDLE_VALUE == hResult)-    return setErrNoFromWin32Error ();--  /* Now we have a Windows handle, we have to convert it to an FD and apply-     the remaining flags.  */-  const int flag_mask = _O_APPEND | _O_RDONLY | _O_TEXT | _O_WTEXT;-  int fd = _open_osfhandle ((intptr_t)hResult, oflag & flag_mask);-  if (-1 == fd)-    return setErrNoFromWin32Error ();--  /* Finally we can change the mode to the requested one.  */-  const int mode_mask = _O_TEXT | _O_BINARY | _O_U16TEXT | _O_U8TEXT | _O_WTEXT;-  if ((oflag & mode_mask) && (-1 == _setmode (fd, oflag & mode_mask)))-    return setErrNoFromWin32Error ();--  return fd;-}--int FS(translate_mode) (const wchar_t* mode)-{-  int oflag = 0;-  int len = wcslen (mode);-  int i;-  #define IS_EXT(X) ((i < (len - 1)) && mode[i+1] == X)--  for (i = 0; i < len; i++)-    {-      switch (mode[i])-        {-          case L'a':-            if (IS_EXT (L'+'))-              oflag |= _O_RDWR | _O_CREAT | _O_APPEND;-            else-              oflag |= _O_WRONLY | _O_CREAT | _O_APPEND;-            break;-          case L'r':-            if (IS_EXT (L'+'))-              oflag |= _O_RDWR;-            else-              oflag |= _O_RDONLY;-            break;-          case L'w':-            if (IS_EXT (L'+'))-              oflag |= _O_RDWR | _O_CREAT | _O_TRUNC;-            else-              oflag |= _O_WRONLY | _O_CREAT | _O_TRUNC;-            break;-          case L'b':-            oflag |= _O_BINARY;-            break;-          case L't':-            oflag |= _O_TEXT;-            break;-          case L'c':-          case L'n':-            oflag |= 0;-            break;-          case L'S':-            oflag |= _O_SEQUENTIAL;-            break;-          case L'R':-            oflag |= _O_RANDOM;-            break;-          case L'T':-            oflag |= _O_SHORT_LIVED;-            break;-          case L'D':-            oflag |= _O_TEMPORARY;-            break;-          default:-            if (wcsncmp (mode, L"ccs=UNICODE", 11) == 0)-              oflag |= _O_WTEXT;-            else if (wcsncmp (mode, L"ccs=UTF-8", 9) == 0)-              oflag |= _O_U8TEXT;-            else if (wcsncmp (mode, L"ccs=UTF-16LE", 12) == 0)-              oflag |= _O_U16TEXT;-            else continue;-        }-    }-  #undef IS_EXT--  return oflag;-}--FILE *FS(fwopen) (const wchar_t* filename, const wchar_t* mode)-{-  int shflag = 0;-  int pmode  = 0;-  int oflag  = FS(translate_mode) (mode);--  int fd = FS(swopen) (filename, oflag, shflag, pmode);-  if (fd < 0)-    return NULL;--  FILE* file = _wfdopen (fd, mode);-  return file;-}--FILE *FS(fopen) (const char* filename, const char* mode)-{-  wchar_t * const w_filename = FS(to_wide) (filename);-  wchar_t * const w_mode = FS(to_wide) (mode);--  FILE *result = FS(fwopen) (w_filename, w_mode);-  free (w_filename);-  free (w_mode);--  return result;-}--int FS(sopen) (const char* filename, int oflag, int shflag, int pmode)-{-  wchar_t * const w_filename = FS(to_wide) (filename);-  int result = FS(swopen) (w_filename, oflag, shflag, pmode);-  free (w_filename);--  return result;-}--int FS(_stat) (const char *path, struct _stat *buffer)-{-  wchar_t * const w_path = FS(to_wide) (path);-  int result = FS(_wstat) (w_path, buffer);-  free (w_path);--  return result;-}--int FS(_stat64) (const char *path, struct __stat64 *buffer)-{-  wchar_t * const w_path = FS(to_wide) (path);-  int result = FS(_wstat64) (w_path, buffer);-  free (w_path);--  return result;-}--static __time64_t ftToPosix(FILETIME ft)-{-  /* takes the last modified date.  */-  LARGE_INTEGER date, adjust;-  date.HighPart = ft.dwHighDateTime;-  date.LowPart = ft.dwLowDateTime;--  /* 100-nanoseconds = milliseconds * 10000.  */-  /* A UNIX timestamp contains the number of seconds from Jan 1, 1970, while the-     FILETIME documentation says: Contains a 64-bit value representing the-     number of 100-nanosecond intervals since January 1, 1601 (UTC).--     Between Jan 1, 1601 and Jan 1, 1970 there are 11644473600 seconds */-  adjust.QuadPart = 11644473600000 * 10000;--  /* removes the diff between 1970 and 1601.  */-  date.QuadPart -= adjust.QuadPart;--  /* converts back from 100-nanoseconds to seconds.  */-  return (__time64_t)date.QuadPart / 10000000;-}--int FS(_wstat) (const wchar_t *path, struct _stat *buffer)-{-  ZeroMemory (buffer, sizeof (struct _stat));-  wchar_t* _path = FS(create_device_name) (path);-  if (!_path)-    return -1;--    /* Construct shared mode.  */-  DWORD dwShareMode = FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE;-  DWORD dwDesiredAccess = FILE_READ_ATTRIBUTES;-  DWORD dwFlagsAndAttributes = FILE_FLAG_BACKUP_SEMANTICS;-  DWORD dwCreationDisposition = OPEN_EXISTING;--  SECURITY_ATTRIBUTES securityAttributes;-  ZeroMemory (&securityAttributes, sizeof(SECURITY_ATTRIBUTES));-  securityAttributes.bInheritHandle       = false;-  securityAttributes.lpSecurityDescriptor = NULL;-  securityAttributes.nLength              = sizeof(SECURITY_ATTRIBUTES);--  HANDLE hResult-    = CreateFileW (_path, dwDesiredAccess, dwShareMode, &securityAttributes,-                   dwCreationDisposition, dwFlagsAndAttributes, NULL);--  if (INVALID_HANDLE_VALUE == hResult)-    {-      free (_path);-      return setErrNoFromWin32Error ();-    }--  WIN32_FILE_ATTRIBUTE_DATA finfo;-  ZeroMemory (&finfo, sizeof (WIN32_FILE_ATTRIBUTE_DATA));-  if(!GetFileAttributesExW (_path, GetFileExInfoStandard, &finfo))-    {-      free (_path);-      CloseHandle (hResult);-      return setErrNoFromWin32Error ();-    }--  unsigned short mode = _S_IREAD;--  if (finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)-    mode |= (_S_IFDIR | _S_IEXEC);-  else-  {-    mode |= _S_IFREG;-    DWORD type;-    if (GetBinaryTypeW (_path, &type))-      mode |= _S_IEXEC;-  }--  if (!(finfo.dwFileAttributes & FILE_ATTRIBUTE_READONLY))-    mode |= _S_IWRITE;--  buffer->st_mode  = mode;-  buffer->st_nlink = 1;-  buffer->st_size  = ((uint64_t)finfo.nFileSizeHigh << 32) + finfo.nFileSizeLow;-  buffer->st_atime = ftToPosix (finfo.ftLastAccessTime);-  buffer->st_mtime = buffer->st_ctime = ftToPosix (finfo.ftLastWriteTime);-  free (_path);-  CloseHandle (hResult);-  return 0;-}--int FS(_wstat64) (const wchar_t *path, struct __stat64 *buffer)-{-  struct _stat buf;-  ZeroMemory (buffer, sizeof (struct __stat64));--  int result = FS(_wstat) (path, &buf);--  buffer->st_mode = buf.st_mode;-  buffer->st_nlink = 1;-  buffer->st_size = buf.st_size;-  buffer->st_atime = buf.st_atime;-  buffer->st_mtime = buf.st_mtime;--  return result;-}--int FS(_wrename) (const wchar_t *from, const wchar_t *to)-{-  wchar_t* const _from = FS(create_device_name) (from);-  if (!_from)-    return -1;--  wchar_t* const _to = FS(create_device_name) (to);-  if (!_to)-    {-      free (_from);-      return -1;-    }--  if (MoveFileW(_from, _to) == 0) {-    free (_from);-    free (_to);-    return setErrNoFromWin32Error ();-  }---  free (_from);-  free (_to);-  return 0;-}--int FS(rename) (const char *from, const char *to)-{-  wchar_t * const w_from = FS(to_wide) (from);-  wchar_t * const w_to = FS(to_wide) (to);-  int result = FS(_wrename) (w_from, w_to);-  free(w_from);-  free(w_to);--  return result;-}--int FS(unlink) (const char *filename)-{-  return FS(_unlink) (filename);-}--int FS(_unlink) (const char *filename)-{-  wchar_t * const w_filename = FS(to_wide) (filename);-  int result = FS(_wunlink) (w_filename);-  free(w_filename);--  return result;-}--int FS(_wunlink) (const wchar_t *filename)-{-  wchar_t* const _filename = FS(create_device_name) (filename);-  if (!_filename)-    return -1;--  if (DeleteFileW(_filename) == 0) {-    free (_filename);-    return setErrNoFromWin32Error ();-  }---  free (_filename);-  return 0;-}-int FS(remove) (const char *path)-{-  return FS(_unlink) (path);-}-int FS(_wremove) (const wchar_t *path)-{-  return FS(_wunlink) (path);-}-#else-FILE *FS(fopen) (const char* filename, const char* mode)-{-  return fopen (filename, mode);-}-#endif
− cbits/iconv.c 
@@ -1,25 +0,0 @@-#if !defined(_WIN32)--#include <stdlib.h>-#include <iconv.h>--iconv_t hs_iconv_open(const char* tocode,-		      const char* fromcode)-{-	return iconv_open(tocode, fromcode);-}--size_t hs_iconv(iconv_t cd,-		const char* * inbuf, size_t * inbytesleft,-		char* * outbuf, size_t * outbytesleft)-{-    // (void*) cast avoids a warning.  Some iconvs use (const-    // char**inbuf), other use (char **inbuf).-    return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft);-}--int hs_iconv_close(iconv_t cd) {-	return iconv_close(cd);-}--#endif
− cbits/inputReady.c 
@@ -1,480 +0,0 @@-/*- * (c) The GRASP/AQUA Project, Glasgow University, 1994-2002- *- * hWaitForInput Runtime Support- */--/* FD_SETSIZE defaults to 64 on Windows, which makes even the most basic- * programs break that use select() on a socket FD.- * Thus we raise it here (before any #include of network-related headers)- * to 1024 so that at least those programs would work that would work on- * Linux if that used select() (luckily it uses poll() by now).- * See https://gitlab.haskell.org/ghc/ghc/issues/13497#note_140304- * The real solution would be to remove all uses of select()- * on Windows, too, and use IO Completion Ports instead.- * Note that on Windows, one can simply define FD_SETSIZE to the desired- * size before including Winsock2.h, as described here:- *   https://msdn.microsoft.com/en-us/library/windows/desktop/ms740141(v=vs.85).aspx- */-#if defined(_WIN32)-#define FD_SETSIZE 1024-#endif--/* select and supporting types is not Posix */-/* #include "PosixSource.h" */-#include "Rts.h"-#include <limits.h>-#include <stdbool.h>-#include "HsBase.h"-#if !defined(_WIN32)-#include <poll.h>-#endif--/*- * Returns a timeout suitable to be passed into poll().- *- * If `remaining` contains a fractional milliseconds part that cannot be passed- * to poll(), this function will return the next larger value that can, so- * that the timeout passed to poll() would always be `>= remaining`.- *- * If `infinite`, `remaining` is ignored.- */-static inline-int-compute_poll_timeout(bool infinite, Time remaining)-{-    if (infinite) return -1;--    if (remaining < 0) return 0;--    if (remaining > MSToTime(INT_MAX)) return INT_MAX;--    int remaining_ms = TimeToMS(remaining);--    if (remaining != MSToTime(remaining_ms)) return remaining_ms + 1;--    return remaining_ms;-}--#if defined(_WIN32)-/*- * Returns a timeout suitable to be passed into select() on Windows.- *- * The given `remaining_tv` serves as a storage for the timeout- * when needed, but callers should use the returned value instead- * as it will not be filled in all cases.- *- * If `infinite`, `remaining` is ignored and `remaining_tv` not touched- * (and may be passed as NULL in that case).- */-static inline-struct timeval *-compute_windows_select_timeout(bool infinite, Time remaining,-                               /* out */ struct timeval * remaining_tv)-{-    if (infinite) {-        return NULL;-    }--    ASSERT(remaining_tv);--    if (remaining < 0) {-        remaining_tv->tv_sec = 0;-        remaining_tv->tv_usec = 0;-    } else if (remaining > MSToTime(LONG_MAX)) {-        remaining_tv->tv_sec = LONG_MAX;-        remaining_tv->tv_usec = LONG_MAX;-    } else {-        remaining_tv->tv_sec  = TimeToMS(remaining) / 1000;-        remaining_tv->tv_usec = TimeToUS(remaining) % 1000000;-    }--    return remaining_tv;-}--/*- * Returns a timeout suitable to be passed into WaitForSingleObject() on- * Windows.- *- * If `remaining` contains a fractional milliseconds part that cannot be passed- * to WaitForSingleObject(), this function will return the next larger value- * that can, so that the timeout passed to WaitForSingleObject() would- * always be `>= remaining`.- *- * If `infinite`, `remaining` is ignored.- */-static inline-DWORD-compute_WaitForSingleObject_timeout(bool infinite, Time remaining)-{-    // WaitForSingleObject() has the fascinating delicacy behaviour-    // that it waits indefinitely if the `DWORD dwMilliseconds`-    // is set to 0xFFFFFFFF (the maximum DWORD value), which is-    // 4294967295 seconds == ~49.71 days-    // (the Windows API calls this constant INFINITE...).-    //   https://msdn.microsoft.com/en-us/library/windows/desktop/ms687032(v=vs.85).aspx-    //-    // We ensure that if accidentally `remaining == 4294967295`, it does-    // NOT wait forever, by never passing that value to-    // WaitForSingleObject() (so, never returning it from this function),-    // unless `infinite`.--    if (infinite) return INFINITE;--    if (remaining < 0) return 0;--    if (remaining >= MSToTime(INFINITE)) return INFINITE - 1;--    DWORD remaining_ms = TimeToMS(remaining);--    if (remaining != MSToTime(remaining_ms)) return remaining_ms + 1;--    return remaining_ms;-}-#endif--/*- * inputReady(fd) checks to see whether input is available on the file- * descriptor 'fd' within 'msecs' milliseconds (or indefinitely if 'msecs' is- * negative). "Input is available" is defined as 'can I safely read at least a- * *character* from this file object without blocking?' (this does not work- * reliably on Linux when the fd is a not-O_NONBLOCK socket, so if you pass- * socket fds to this function, ensure they have O_NONBLOCK;- * see `man 2 poll` and `man 2 select`, and- * https://gitlab.haskell.org/ghc/ghc/issues/13497#note_140309).- *- * This function blocks until either `msecs` have passed, or input is- * available.- *- * Returns:- *   1 => Input ready, 0 => not ready, -1 => error- * On error, sets `errno`.- */-int-fdReady(int fd, bool write, int64_t msecs, bool isSock)-{-    bool infinite = msecs < 0;--    // if we need to track the time then record the end time in case we are-    // interrupted.-    Time endTime = 0;-    if (msecs > 0) {-        endTime = getProcessElapsedTime() + MSToTime(msecs);-    }--    // Invariant of all code below:-    // If `infinite`, then `remaining` and `endTime` are never used.--    Time remaining = MSToTime(msecs);--    // Note [Guaranteed syscall time spent]-    //-    // The implementation ensures that if fdReady() is called with N `msecs`,-    // it will not return before an FD-polling syscall *returns*-    // with `endTime` having passed.-    //-    // Consider the following scenario:-    //-    //     1 int ready = poll(..., msecs);-    //     2 if (EINTR happened) {-    //     3   Time now = getProcessElapsedTime();-    //     4   if (now >= endTime) return 0;-    //     5   remaining = endTime - now;-    //     6 }-    //-    // If `msecs` is 5 seconds, but in line 1 poll() returns with EINTR after-    // only 10 ms due to a signal, and if at line 2 the machine starts-    // swapping for 10 seconds, then line 4 will return that there's no-    // data ready, even though by now there may be data ready now, and we have-    // not actually checked after up to `msecs` = 5 seconds whether there's-    // data ready as promised.-    //-    // Why is this important?-    // Assume you call the pizza man to bring you a pizza.-    // You arrange that you won't pay if he doesn't ring your doorbell-    // in under 10 minutes delivery time.-    // At 9:58 fdReady() gets woken by EINTR and then your computer swaps-    // for 3 seconds.-    // At 9:59 the pizza man rings.-    // At 10:01 fdReady() will incorrectly tell you that the pizza man hasn't-    // rung within 10 minutes, when in fact he has.-    //-    // If the pizza man is some watchdog service or dead man's switch program,-    // this is problematic.-    //-    // To avoid it, we ensure that in the timeline diagram:-    //-    //                      endTime-    //                         |-    //     time ----+----------+-------+---->-    //              |                  |-    //       syscall starts     syscall returns-    //-    // the "syscall returns" event is always >= the "endTime" time.-    //-    // In the code this means that we never check whether to `return 0`-    // after a `Time now = getProcessElapsedTime();`, and instead always-    // let the branch marked [we waited the full msecs] handle that case.--#if !defined(_WIN32)-    struct pollfd fds[1];--    fds[0].fd = fd;-    fds[0].events = write ? POLLOUT : POLLIN;-    fds[0].revents = 0;--    // The code below tries to make as few syscalls as possible;-    // in particular, it eschews getProcessElapsedTime() calls-    // when `infinite` or `msecs == 0`.--    // We need to wait in a loop because poll() accepts `int` but `msecs` is-    // `int64_t`, and because signals can interrupt it.--    while (true) {-        int res = poll(fds, 1, compute_poll_timeout(infinite, remaining));--        if (res < 0 && errno != EINTR)-            return (-1); // real error; errno is preserved--        if (res > 0)-            return 1; // FD has new data--        if (res == 0 && !infinite && remaining <= MSToTime(INT_MAX))-            return 0; // FD has no new data and [we waited the full msecs]--        // Non-exit cases-        CHECK( ( res < 0 && errno == EINTR ) || // EINTR happened-               // need to wait more-               ( res == 0 && (infinite ||-                              remaining > MSToTime(INT_MAX)) ) );--        if (!infinite) {-            Time now = getProcessElapsedTime();-            remaining = endTime - now;-        }-    }--#else--    if (isSock) {-        int maxfd;-        fd_set rfd, wfd;-        struct timeval remaining_tv;--        if ((fd >= (int)FD_SETSIZE) || (fd < 0)) {-            barf("fdReady: fd is too big: %d but FD_SETSIZE is %d", fd, (int)FD_SETSIZE);-        }-        FD_ZERO(&rfd);-        FD_ZERO(&wfd);-        if (write) {-            FD_SET(fd, &wfd);-        } else {-            FD_SET(fd, &rfd);-        }--        /* select() will consider the descriptor set in the range of 0 to-         * (maxfd-1)-         */-        maxfd = fd + 1;--        // We need to wait in a loop because the `timeval` `tv_*` members-        // passed into select() accept are `long` (which is 32 bits on 32-bit-        // and 64-bit Windows), but `msecs` is `int64_t`, and because signals-        // can interrupt it.-        //   https://msdn.microsoft.com/en-us/library/windows/desktop/ms740560(v=vs.85).aspx-        //   https://stackoverflow.com/questions/384502/what-is-the-bit-size-of-long-on-64-bit-windows#384672--        while (true) {-            int res = select(maxfd, &rfd, &wfd, NULL,-                             compute_windows_select_timeout(infinite, remaining,-                                                            &remaining_tv));--            if (res < 0 && errno != EINTR)-                return (-1); // real error; errno is preserved--            if (res > 0)-                return 1; // FD has new data--            if (res == 0 && !infinite && remaining <= MSToTime(INT_MAX))-                return 0; // FD has no new data and [we waited the full msecs]--            // Non-exit cases-            CHECK( ( res < 0 && errno == EINTR ) || // EINTR happened-                   // need to wait more-                   ( res == 0 && (infinite ||-                                  remaining > MSToTime(INT_MAX)) ) );--            if (!infinite) {-                Time now = getProcessElapsedTime();-                remaining = endTime - now;-            }-        }--    } else {-        DWORD rc;-        HANDLE hFile = (HANDLE)_get_osfhandle(fd);-        DWORD avail = 0;--        switch (GetFileType(hFile)) {--            case FILE_TYPE_CHAR:-                {-                    INPUT_RECORD buf[1];-                    DWORD count;--                    // nightmare.  A Console Handle will appear to be ready-                    // (WaitForSingleObject() returned WAIT_OBJECT_0) when-                    // it has events in its input buffer, but these events might-                    // not be keyboard events, so when we read from the Handle the-                    // read() will block.  So here we try to discard non-keyboard-                    // events from a console handle's input buffer and then try-                    // the WaitForSingleObject() again.--                    while (1) // keep trying until we find a real key event-                    {-                        rc = WaitForSingleObject(-                            hFile,-                            compute_WaitForSingleObject_timeout(infinite, remaining));-                        switch (rc) {-                            case WAIT_TIMEOUT:-                                // We need to use < here because if remaining-                                // was INFINITE, we'll have waited for-                                // `INFINITE - 1` as per-                                // compute_WaitForSingleObject_timeout(),-                                // so that's 1 ms too little. Wait again then.-                                if (!infinite && remaining < MSToTime(INFINITE))-                                    return 0; // real complete or [we waited the full msecs]-                                goto waitAgain;-                            case WAIT_OBJECT_0: break;-                            default: /* WAIT_FAILED */ maperrno(); return -1;-                        }--                        while (1) // discard non-key events-                        {-                            BOOL success = PeekConsoleInput(hFile, buf, 1, &count);-                            // printf("peek, rc=%d, count=%d, type=%d\n", rc, count, buf[0].EventType);-                            if (!success) {-                                rc = GetLastError();-                                if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) {-                                    return 1;-                                } else {-                                    maperrno();-                                    return -1;-                                }-                            }--                            if (count == 0) break; // no more events => wait again--                            // discard console events that are not "key down", because-                            // these will also be discarded by ReadFile().-                            if (buf[0].EventType == KEY_EVENT &&-                                buf[0].Event.KeyEvent.bKeyDown &&-                                buf[0].Event.KeyEvent.uChar.AsciiChar != '\0')-                            {-                                // it's a proper keypress:-                                return 1;-                            }-                            else-                            {-                                // it's a non-key event, a key up event, or a-                                // non-character key (e.g. shift).  discard it.-                                BOOL success = ReadConsoleInput(hFile, buf, 1, &count);-                                if (!success) {-                                    rc = GetLastError();-                                    if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) {-                                        return 1;-                                    } else {-                                        maperrno();-                                        return -1;-                                    }-                                }-                            }-                        }--                        Time now;-                    waitAgain:-                        now = getProcessElapsedTime();-                        remaining = endTime - now;-                    }-                }--            case FILE_TYPE_DISK:-                // assume that disk files are always ready:-                return 1;--            case FILE_TYPE_PIPE: {-                // WaitForMultipleObjects() doesn't work for pipes (it-                // always returns WAIT_OBJECT_0 even when no data is-                // available).  If the HANDLE is a pipe, therefore, we try-                // PeekNamedPipe():-                //-                // PeekNamedPipe() does not block, so if it returns that-                // there is no new data, we have to sleep and try again.--                // Because PeekNamedPipe() doesn't block, we have to track-                // manually whether we've called it one more time after `endTime`-                // to fulfill Note [Guaranteed syscall time spent].-                bool endTimeReached = false;-                while (avail == 0) {-                    BOOL success = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL );-                    if (success) {-                        if (avail != 0) {-                            return 1;-                        } else { // no new data-                            if (infinite) {-                                Sleep(1); // 1 millisecond (smallest possible time on Windows)-                                continue;-                            } else if (msecs == 0) {-                                return 0;-                            } else {-                                if (endTimeReached) return 0; // [we waited the full msecs]-                                Time now = getProcessElapsedTime();-                                if (now >= endTime) endTimeReached = true;-                                Sleep(1); // 1 millisecond (smallest possible time on Windows)-                                continue;-                            }-                        }-                    } else {-                        rc = GetLastError();-                        if (rc == ERROR_BROKEN_PIPE) {-                            return 1; // this is probably what we want-                        }-                        if (rc != ERROR_INVALID_HANDLE && rc != ERROR_INVALID_FUNCTION) {-                            maperrno();-                            return -1;-                        }-                    }-                }-            }-            /* PeekNamedPipe didn't work - fall through to the general case */--            default:-                while (true) {-                    rc = WaitForSingleObject(-                        hFile,-                        compute_WaitForSingleObject_timeout(infinite, remaining));--                    switch (rc) {-                        case WAIT_TIMEOUT:-                            // We need to use < here because if remaining-                            // was INFINITE, we'll have waited for-                            // `INFINITE - 1` as per-                            // compute_WaitForSingleObject_timeout(),-                            // so that's 1 ms too little. Wait again then.-                            if (!infinite && remaining < MSToTime(INFINITE))-                                return 0; // real complete or [we waited the full msecs]-                            break;-                        case WAIT_OBJECT_0: return 1;-                        default: /* WAIT_FAILED */ maperrno(); return -1;-                    }--                    // EINTR or a >(INFINITE - 1) timeout completed-                    if (!infinite) {-                        Time now = getProcessElapsedTime();-                        remaining = endTime - now;-                    }-                }-        }-    }-#endif-}
− cbits/md5.c 
@@ -1,238 +0,0 @@-/*- * This code implements the MD5 message-digest algorithm.- * The algorithm is due to Ron Rivest.  This code was- * written by Colin Plumb in 1993, no copyright is claimed.- * This code is in the public domain; do with it what you wish.- *- * Equivalent code is available from RSA Data Security, Inc.- * This code has been tested against that, and is equivalent,- * except that you don't need to include two pages of legalese- * with every copy.- *- * To compute the message digest of a chunk of bytes, declare an- * MD5Context structure, pass it to MD5Init, call MD5Update as- * needed on buffers full of bytes, and then call MD5Final, which- * will fill a supplied 16-byte array with the digest.- */--#include "HsFFI.h"-#include "md5.h"-#include <string.h>--void __hsbase_MD5Init(struct MD5Context *context);-void __hsbase_MD5Update(struct MD5Context *context, uint8_t const *buf, int len);-void __hsbase_MD5Final(uint8_t digest[16], struct MD5Context *context);-void __hsbase_MD5Transform(uint32_t buf[4], uint32_t const in[16]);---/*- * Shuffle the bytes into little-endian order within words, as per the- * MD5 spec.  Note: this code works regardless of the byte order.- */-static void-byteSwap(uint32_t *buf, unsigned words)-{-	uint8_t *p = (uint8_t *)buf;--	do {-		*buf++ = (uint32_t)((unsigned)p[3] << 8 | p[2]) << 16 |-			((unsigned)p[1] << 8 | p[0]);-		p += 4;-	} while (--words);-}--/*- * Start MD5 accumulation.  Set bit count to 0 and buffer to mysterious- * initialization constants.- */-void-__hsbase_MD5Init(struct MD5Context *ctx)-{-	ctx->buf[0] = 0x67452301;-	ctx->buf[1] = 0xefcdab89;-	ctx->buf[2] = 0x98badcfe;-	ctx->buf[3] = 0x10325476;--	ctx->bytes[0] = 0;-	ctx->bytes[1] = 0;-}--/*- * Update context to reflect the concatenation of another buffer full- * of bytes.- */-void-__hsbase_MD5Update(struct MD5Context *ctx, uint8_t const *buf, int len)-{-	uint32_t t;--	/* Update byte count */--	t = ctx->bytes[0];-	if ((ctx->bytes[0] = t + len) < t)-		ctx->bytes[1]++;	/* Carry from low to high */--	t = 64 - (t & 0x3f);	/* Space available in ctx->in (at least 1) */-	if ((unsigned)t > len) {-		memcpy((uint8_t *)ctx->in + 64 - (unsigned)t, buf, len);-		return;-	}-	/* First chunk is an odd size */-	memcpy((uint8_t *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);-	byteSwap(ctx->in, 16);-        __hsbase_MD5Transform(ctx->buf, ctx->in);-	buf += (unsigned)t;-	len -= (unsigned)t;--	/* Process data in 64-byte chunks */-	while (len >= 64) {-		memcpy(ctx->in, buf, 64);-		byteSwap(ctx->in, 16);-                __hsbase_MD5Transform(ctx->buf, ctx->in);-		buf += 64;-		len -= 64;-	}--	/* Handle any remaining bytes of data. */-	memcpy(ctx->in, buf, len);-}--/*- * Final wrapup - pad to 64-byte boundary with the bit pattern - * 1 0* (64-bit count of bits processed, MSB-first)- */-void-__hsbase_MD5Final(uint8_t digest[16], struct MD5Context *ctx)-{-	int count = (int)(ctx->bytes[0] & 0x3f); /* Bytes in ctx->in */-	uint8_t *p = (uint8_t *)ctx->in + count;	/* First unused byte */--	/* Set the first char of padding to 0x80.  There is always room. */-	*p++ = 0x80;--	/* Bytes of padding needed to make 56 bytes (-8..55) */-	count = 56 - 1 - count;--	if (count < 0) {	/* Padding forces an extra block */-		memset(p, 0, count+8);-		byteSwap(ctx->in, 16);-                __hsbase_MD5Transform(ctx->buf, ctx->in);-		p = (uint8_t *)ctx->in;-		count = 56;-	}-	memset(p, 0, count+8);-	byteSwap(ctx->in, 14);--	/* Append length in bits and transform */-	ctx->in[14] = ctx->bytes[0] << 3;-	ctx->in[15] = ctx->bytes[1] << 3 | ctx->bytes[0] >> 29;-        __hsbase_MD5Transform(ctx->buf, ctx->in);--	byteSwap(ctx->buf, 4);-	memcpy(digest, ctx->buf, 16);-	memset(ctx, 0, sizeof(*ctx));-}---/* The four core functions - F1 is optimized somewhat */--/* #define F1(x, y, z) (x & y | ~x & z) */-#define F1(x, y, z) (z ^ (x & (y ^ z)))-#define F2(x, y, z) F1(z, x, y)-#define F3(x, y, z) (x ^ y ^ z)-#define F4(x, y, z) (y ^ (x | ~z))--/* This is the central step in the MD5 algorithm. */-#define MD5STEP(f,w,x,y,z,in,s) \-	 (w += f(x,y,z) + in, w = (w<<s | w>>(32-s)) + x)--/*- * The core of the MD5 algorithm, this alters an existing MD5 hash to- * reflect the addition of 16 longwords of new data.  MD5Update blocks- * the data and converts bytes into longwords for this routine.- */--void-__hsbase_MD5Transform(uint32_t buf[4], uint32_t const in[16])-{-	register uint32_t a, b, c, d;--	a = buf[0];-	b = buf[1];-	c = buf[2];-	d = buf[3];--	MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);-	MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);-	MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);-	MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);-	MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);-	MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);-	MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);-	MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);-	MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);-	MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);-	MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);-	MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);-	MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);-	MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);-	MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);-	MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);--	MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);-	MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);-	MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);-	MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);-	MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);-	MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);-	MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);-	MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);-	MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);-	MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);-	MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);-	MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);-	MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);-	MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);-	MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);-	MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);--	MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);-	MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);-	MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);-	MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);-	MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);-	MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);-	MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);-	MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);-	MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);-	MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);-	MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);-	MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);-	MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);-	MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);-	MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);-	MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);--	MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);-	MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);-	MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);-	MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);-	MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);-	MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);-	MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);-	MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);-	MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);-	MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);-	MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);-	MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);-	MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);-	MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);-	MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);-	MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);--	buf[0] += a;-	buf[1] += b;-	buf[2] += c;-	buf[3] += d;-}-
− cbits/primFloat.c 
@@ -1,532 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) Lennart Augustsson- * (c) The GHC Team, 1998-2000- *- * Miscellaneous support for floating-point primitives- *- * ---------------------------------------------------------------------------*/--#include "HsFFI.h"-#include "Rts.h" // XXX wrong (for IEEE_FLOATING_POINT and WORDS_BIGENDIAN)--#define IEEE_FLOATING_POINT 1--union stg_ieee754_flt-{-   float f;-   struct {--#if WORDS_BIGENDIAN-	unsigned int negative:1;-	unsigned int exponent:8;-	unsigned int mantissa:23;-#else-	unsigned int mantissa:23;-	unsigned int exponent:8;-	unsigned int negative:1;-#endif-   } ieee;-   struct {--#if WORDS_BIGENDIAN-	unsigned int negative:1;-	unsigned int exponent:8;-	unsigned int quiet_nan:1;-	unsigned int mantissa:22;-#else-	unsigned int mantissa:22;-	unsigned int quiet_nan:1;-	unsigned int exponent:8;-	unsigned int negative:1;-#endif-   } ieee_nan;-};--/*-- To recap, here's the representation of a double precision- IEEE floating point number:-- sign         63           sign bit (0==positive, 1==negative)- exponent     62-52        exponent (biased by 1023)- fraction     51-0         fraction (bits to right of binary point)-*/--union stg_ieee754_dbl-{-   double d;-   struct {--#if WORDS_BIGENDIAN-	unsigned int negative:1;-	unsigned int exponent:11;-	unsigned int mantissa0:20;-	unsigned int mantissa1:32;-#else-#if FLOAT_WORDS_BIGENDIAN-	unsigned int mantissa0:20;-	unsigned int exponent:11;-	unsigned int negative:1;-	unsigned int mantissa1:32;-#else-	unsigned int mantissa1:32;-	unsigned int mantissa0:20;-	unsigned int exponent:11;-	unsigned int negative:1;-#endif-#endif-   } ieee;-    /* This format makes it easier to see if a NaN is a signalling NaN.  */-   struct {--#if WORDS_BIGENDIAN-	unsigned int negative:1;-	unsigned int exponent:11;-	unsigned int quiet_nan:1;-	unsigned int mantissa0:19;-	unsigned int mantissa1:32;-#else-#if FLOAT_WORDS_BIGENDIAN-	unsigned int mantissa0:19;-	unsigned int quiet_nan:1;-	unsigned int exponent:11;-	unsigned int negative:1;-	unsigned int mantissa1:32;-#else-	unsigned int mantissa1:32;-	unsigned int mantissa0:19;-	unsigned int quiet_nan:1;-	unsigned int exponent:11;-	unsigned int negative:1;-#endif-#endif-   } ieee_nan;-};--/*- * Predicates for testing for extreme IEEE fp values.- */--/* In case you don't support IEEE, you'll just get dummy defs.. */-#if defined(IEEE_FLOATING_POINT)--HsInt-isDoubleFinite(HsDouble d)-{-  union stg_ieee754_dbl u;--  u.d = d;--  return u.ieee.exponent != 2047;-}--HsInt-isDoubleNaN(HsDouble d)-{-  union stg_ieee754_dbl u;--  u.d = d;--  return (-    u.ieee.exponent  == 2047 /* 2^11 - 1 */ &&  /* Is the exponent all ones? */-    (u.ieee.mantissa0 != 0 || u.ieee.mantissa1 != 0)-    	/* and the mantissa non-zero? */-    );-}--HsInt-isDoubleInfinite(HsDouble d)-{-    union stg_ieee754_dbl u;--    u.d = d;--    /* Inf iff exponent is all ones, mantissa all zeros */-    return (-        u.ieee.exponent  == 2047 /* 2^11 - 1 */ &&-	u.ieee.mantissa0 == 0 		        &&-	u.ieee.mantissa1 == 0-      );-}--HsInt-isDoubleDenormalized(HsDouble d)-{-    union stg_ieee754_dbl u;--    u.d = d;--    /* A (single/double/quad) precision floating point number-       is denormalised iff:-        - exponent is zero-	- mantissa is non-zero.-        - (don't care about setting of sign bit.)--    */-    return (-	u.ieee.exponent  == 0 &&-	(u.ieee.mantissa0 != 0 ||-	 u.ieee.mantissa1 != 0)-      );--}--HsInt-isDoubleNegativeZero(HsDouble d)-{-    union stg_ieee754_dbl u;--    u.d = d;-    /* sign (bit 63) set (only) => negative zero */--    return (-    	u.ieee.negative  == 1 &&-	u.ieee.exponent  == 0 &&-	u.ieee.mantissa0 == 0 &&-	u.ieee.mantissa1 == 0);-}--/* Same tests, this time for HsFloats. */--/*- To recap, here's the representation of a single precision- IEEE floating point number:-- sign         31           sign bit (0 == positive, 1 == negative)- exponent     30-23        exponent (biased by 127)- fraction     22-0         fraction (bits to right of binary point)-*/---HsInt-isFloatFinite(HsFloat f)-{-    union stg_ieee754_flt u;-    u.f = f;-    return u.ieee.exponent != 255;-}--HsInt-isFloatNaN(HsFloat f)-{-    union stg_ieee754_flt u;-    u.f = f;--   /* Floating point NaN iff exponent is all ones, mantissa is-      non-zero (but see below.) */-   return (-   	u.ieee.exponent == 255 /* 2^8 - 1 */ &&-	u.ieee.mantissa != 0);-}--HsInt-isFloatInfinite(HsFloat f)-{-    union stg_ieee754_flt u;-    u.f = f;--    /* A float is Inf iff exponent is max (all ones),-       and mantissa is min(all zeros.) */-    return (-    	u.ieee.exponent == 255 /* 2^8 - 1 */ &&-	u.ieee.mantissa == 0);-}--HsInt-isFloatDenormalized(HsFloat f)-{-    union stg_ieee754_flt u;-    u.f = f;--    /* A (single/double/quad) precision floating point number-       is denormalised iff:-        - exponent is zero-	- mantissa is non-zero.-        - (don't care about setting of sign bit.)--    */-    return (-    	u.ieee.exponent == 0 &&-	u.ieee.mantissa != 0);-}--HsInt-isFloatNegativeZero(HsFloat f)-{-    union stg_ieee754_flt u;-    u.f = f;--    /* sign (bit 31) set (only) => negative zero */-    return (-	u.ieee.negative      &&-	u.ieee.exponent == 0 &&-	u.ieee.mantissa == 0);-}--/*- There are glibc versions around with buggy rintf or rint, hence we- provide our own. We always round ties to even, so we can be simpler.-*/--#define FLT_HIDDEN 0x800000-#define FLT_POWER2 0x1000000--HsFloat-rintFloat(HsFloat f)-{-    union stg_ieee754_flt u;-    u.f = f;-    /* if real exponent > 22, it's already integral, infinite or nan */-    if (u.ieee.exponent > 149)  /* 22 + 127 */-    {-        return u.f;-    }-    if (u.ieee.exponent < 126)  /* (-1) + 127, abs(f) < 0.5 */-    {-        /* only used for rounding to Integral a, so don't care about -0.0 */-        return 0.0;-    }-    /* 0.5 <= abs(f) < 2^23 */-    unsigned int half, mask, mant, frac;-    half = 1 << (149 - u.ieee.exponent);    /* bit for 0.5 */-    mask = 2*half - 1;                      /* fraction bits */-    mant = u.ieee.mantissa | FLT_HIDDEN;    /* add hidden bit */-    frac = mant & mask;                     /* get fraction */-    mant ^= frac;                           /* truncate mantissa */-    if ((frac < half) || ((frac == half) && ((mant & (2*half)) == 0)))-    {-        /* this means we have to truncate */-        if (mant == 0)-        {-            /* f == ±0.5, return 0.0 */-            return 0.0;-        }-        else-        {-            /* remove hidden bit and set mantissa */-            u.ieee.mantissa = mant ^ FLT_HIDDEN;-            return u.f;-        }-    }-    else-    {-        /* round away from zero, increment mantissa */-        mant += 2*half;-        if (mant == FLT_POWER2)-        {-            /* next power of 2, increase exponent and set mantissa to 0 */-            u.ieee.mantissa = 0;-            u.ieee.exponent += 1;-            return u.f;-        }-        else-        {-            /* remove hidden bit and set mantissa */-            u.ieee.mantissa = mant ^ FLT_HIDDEN;-            return u.f;-        }-    }-}--#define DBL_HIDDEN 0x100000-#define DBL_POWER2 0x200000-#define LTOP_BIT 0x80000000--HsDouble-rintDouble(HsDouble d)-{-    union stg_ieee754_dbl u;-    u.d = d;-    /* if real exponent > 51, it's already integral, infinite or nan */-    if (u.ieee.exponent > 1074) /* 51 + 1023 */-    {-        return u.d;-    }-    if (u.ieee.exponent < 1022)  /* (-1) + 1023, abs(d) < 0.5 */-    {-        /* only used for rounding to Integral a, so don't care about -0.0 */-        return 0.0;-    }-    unsigned int half, mask, mant, frac;-    if (u.ieee.exponent < 1043) /* 20 + 1023, real exponent < 20 */-    {-        /* the fractional part meets the higher part of the mantissa */-        half = 1 << (1042 - u.ieee.exponent);   /* bit for 0.5 */-        mask = 2*half - 1;                      /* fraction bits */-        mant = u.ieee.mantissa0 | DBL_HIDDEN;   /* add hidden bit */-        frac = mant & mask;                     /* get fraction */-        mant ^= frac;                           /* truncate mantissa */-        if ((frac < half) ||-            ((frac == half) && (u.ieee.mantissa1 == 0)  /* a tie */-                && ((mant & (2*half)) == 0)))-        {-            /* truncate */-            if (mant == 0)-            {-                /* d = ±0.5, return 0.0 */-                return 0.0;-            }-            /* remove hidden bit and set mantissa */-            u.ieee.mantissa0 = mant ^ DBL_HIDDEN;-            u.ieee.mantissa1 = 0;-            return u.d;-        }-        else    /* round away from zero */-        {-            /* zero low mantissa bits */-            u.ieee.mantissa1 = 0;-            /* increment integer part of mantissa */-            mant += 2*half;-            if (mant == DBL_POWER2)-            {-                /* power of 2, increment exponent and zero mantissa */-                u.ieee.mantissa0 = 0;-                u.ieee.exponent += 1;-                return u.d;-            }-            /* remove hidden bit */-            u.ieee.mantissa0 = mant ^ DBL_HIDDEN;-            return u.d;-        }-    }-    else-    {-        /* 20 <= real exponent < 52, fractional part entirely in mantissa1 */-        half = 1 << (1074 - u.ieee.exponent);   /* bit for 0.5 */-        mask = 2*half - 1;                      /* fraction bits */-        mant = u.ieee.mantissa1;                /* no hidden bit here */-        frac = mant & mask;                     /* get fraction */-        mant ^= frac;                           /* truncate mantissa */-        if ((frac < half) ||-            ((frac == half) &&                  /* tie */-            (((half == LTOP_BIT) ? (u.ieee.mantissa0 & 1)  /* yuck */-                                : (mant & (2*half)))-                                        == 0)))-        {-            /* truncate */-            u.ieee.mantissa1 = mant;-            return u.d;-        }-        else-        {-            /* round away from zero */-            /* increment mantissa */-            mant += 2*half;-            u.ieee.mantissa1 = mant;-            if (mant == 0)-            {-                /* low part of mantissa overflowed */-                /* increment high part of mantissa */-                mant = u.ieee.mantissa0 + 1;-                if (mant == DBL_HIDDEN)-                {-                    /* hit power of 2 */-                    /* zero mantissa */-                    u.ieee.mantissa0 = 0;-                    /* and increment exponent */-                    u.ieee.exponent += 1;-                    return u.d;-                }-                else-                {-                    u.ieee.mantissa0 = mant;-                    return u.d;-                }-            }-            else-            {-                return u.d;-            }-        }-    }-}--#else /* ! IEEE_FLOATING_POINT */--/* Dummy definitions of predicates - they all return "normal" values */-HsInt isDoubleFinite(HsDouble d) { return 1;}-HsInt isDoubleNaN(HsDouble d) { return 0; }-HsInt isDoubleInfinite(HsDouble d) { return 0; }-HsInt isDoubleDenormalized(HsDouble d) { return 0; }-HsInt isDoubleNegativeZero(HsDouble d) { return 0; }-HsInt isFloatFinite(HsFloat f) { return 1; }-HsInt isFloatNaN(HsFloat f) { return 0; }-HsInt isFloatInfinite(HsFloat f) { return 0; }-HsInt isFloatDenormalized(HsFloat f) { return 0; }-HsInt isFloatNegativeZero(HsFloat f) { return 0; }---/* For exotic floating point formats, we can't do much */-/* We suppose the format has not too many bits */-/* I hope nobody tries to build GHC where this is wrong */--#define FLT_UPP 536870912.0--HsFloat-rintFloat(HsFloat f)-{-    if ((f > FLT_UPP) || (f < (-FLT_UPP)))-    {-        return f;-    }-    else-    {-        int i = (int)f;-        float g = i;-        float d = f - g;-        if (d > 0.5)-        {-            return g + 1.0;-        }-        if (d == 0.5)-        {-            return (i & 1) ? (g + 1.0) : g;-        }-        if (d == -0.5)-        {-            return (i & 1) ? (g - 1.0) : g;-        }-        if (d < -0.5)-        {-            return g - 1.0;-        }-        return g;-    }-}--#define DBL_UPP 2305843009213693952.0--HsDouble-rintDouble(HsDouble d)-{-    if ((d > DBL_UPP) || (d < (-DBL_UPP)))-    {-        return d;-    }-    else-    {-        HsInt64 i = (HsInt64)d;-        double e = i;-        double r = d - e;-        if (r > 0.5)-        {-            return e + 1.0;-        }-        if (r == 0.5)-        {-            return (i & 1) ? (e + 1.0) : e;-        }-        if (r == -0.5)-        {-            return (i & 1) ? (e - 1.0) : e;-        }-        if (r < -0.5)-        {-            return e - 1.0;-        }-        return e;-    }-}--#endif /* ! IEEE_FLOATING_POINT */
− cbits/sysconf.c 
@@ -1,19 +0,0 @@-#include "HsBaseConfig.h"--/* For _SC_CLK_TCK */-#if HAVE_UNISTD_H-#include <unistd.h>-#endif--/* for CLK_TCK */-#if HAVE_TIME_H-#include <time.h>-#endif--long clk_tck(void) {-#if defined(CLK_TCK)-    return (CLK_TCK);-#else-    return sysconf(_SC_CLK_TCK);-#endif-}
changelog.md view
@@ -1,28 +1,372 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) -## 4.16.4.0 *Nov 2022*+## 4.22.0.0 *December 2025*+  * Shipped with GHC 9.14.1+  * The internal `GHC.Weak.Finalize.runFinalizerBatch` function has been deprecated ([CLC proposal #342](https://github.com/haskell/core-libraries-committee/issues/342))+  * Define `displayException` of `SomeAsyncException` to unwrap the exception.+      ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309))+  * Restrict `Data.List.NonEmpty.unzip` to `NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)`. ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86))+  * Modify the implementation of `Control.Exception.throw` to avoid call-sites being inferred as diverging via precise exception.+    ([GHC #25066](https://gitlab.haskell.org/ghc/ghc/-/issues/25066), [CLC proposal #290](https://github.com/haskell/core-libraries-committee/issues/290))+  * `Data.List.NonEmpty.{init,last,tails1}` are now defined using only total functions (rather than partial ones). ([CLC proposal #293](https://github.com/haskell/core-libraries-committee/issues/293))+  * `Data.List.NonEmpty` functions now have the same laziness as their `Data.List` counterparts (i.e. make them more strict than they currently are) ([CLC proposal #107](https://github.com/haskell/core-libraries-committee/issues/107))+  * `instance Functor NonEmpty` is now specified using `map` (rather than duplicating code). ([CLC proposal #300](https://github.com/haskell/core-libraries-committee/issues/300))+  * `fail` from `MonadFail` now carries `HasCallStack` constraint. ([CLC proposal #327](https://github.com/haskell/core-libraries-committee/issues/327))+  * The `Data.Enum.enumerate` function was introduced ([CLC #306](https://github.com/haskell/core-libraries-committee/issues/306))+  * Worker threads used by various `base` facilities are now labelled with descriptive thread labels ([CLC proposal #305](https://github.com/haskell/core-libraries-committee/issues/305), [GHC #25452](https://gitlab.haskell.org/ghc/ghc/-/issues/25452)). Specifically, these include:+    * `Control.Concurrent.threadWaitRead`+    * `Control.Concurrent.threadWaitWrite`+    * `Control.Concurrent.threadWaitReadSTM`+    * `Control.Concurrent.threadWaitWriteSTM`+    * `System.Timeout.timeout`+    * `GHC.Conc.Signal.runHandlers`+  * The following internal modules have been removed from `base`, as per [CLC #217](https://github.com/haskell/core-libraries-committee/issues/217):+      * `GHC.TypeLits.Internal`+      * `GHC.TypeNats.Internal`+      * `GHC.ExecutionStack.Internal`.+  * Deprecate `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329)+  * Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)).+  * Fix the rewrite rule for `scanl'` not being strict in the first element of the output list ([#26143](https://gitlab.haskell.org/ghc/ghc/-/issues/26143)).+  * `GHC.Exts.IOPort#` and its related operations have been removed  ([CLC #213](https://github.com/haskell/core-libraries-committee/issues/213))+  * Remove deprecated, unstable heap representation details from `GHC.Exts` ([CLC proposal #212](https://github.com/haskell/core-libraries-committee/issues/212)) -  * Shipped with GHC 9.2.5+## 4.21.0.0 *December 2024*+  * Shipped with GHC 9.12.1+  * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55))+  * Introduce `Data.Bounded` module exporting the `Bounded` typeclass (finishing [CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208))+  * Deprecate export of `Bounded` class from `Data.Enum` ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208))+  * `GHC.Desugar` has been deprecated and should be removed in GHC 9.14. ([CLC proposal #216](https://github.com/haskell/core-libraries-committee/issues/216))+  * Add a `readTixFile` field to the `HpcFlags` record in `GHC.RTS.Flags` ([CLC proposal #276](https://github.com/haskell/core-libraries-committee/issues/276))+  * Add `compareLength` to `Data.List` and `Data.List.NonEmpty` ([CLC proposal #257](https://github.com/haskell/core-libraries-committee/issues/257))+  * Add `INLINE[1]` to `compareInt` / `compareWord` ([CLC proposal #179](https://github.com/haskell/core-libraries-committee/issues/179))+  * Refactor `GHC.RTS.Flags` in preparation for new I/O managers: introduce `data IoManagerFlag` and use it in `MiscFlags`, remove `getIoManagerFlag`, deprecate re-export of `IoSubSystem` ([CLC proposal #263](https://github.com/haskell/core-libraries-committee/issues/263))+  * Add the `MonadFix` instance for `(,) a`, similar to the one for `Writer a` ([CLC proposal #238](https://github.com/haskell/core-libraries-committee/issues/238))+  * Improve `toInteger :: Word32 -> Integer` on 64-bit platforms ([CLC proposal #259](https://github.com/haskell/core-libraries-committee/issues/259))+  * Make `flip` representation polymorphic ([CLC proposal #245](https://github.com/haskell/core-libraries-committee/issues/245))+  * The `HasField` class now supports representation polymorphism ([CLC proposal #194](https://github.com/haskell/core-libraries-committee/issues/194))+  * Make `read` accept binary integer notation ([CLC proposal #177](https://github.com/haskell/core-libraries-committee/issues/177))+  * Improve the performance of `Data.List.sort` using an improved merging strategy. Instead of `compare`, `sort` now uses `(>)` which may break *malformed* `Ord` instances ([CLC proposal #236](https://github.com/haskell/core-libraries-committee/issues/236))+  * Add `inits1` and `tails1` to `Data.List`, factored from the corresponding functions in `Data.List.NonEmpty` ([CLC proposal #252](https://github.com/haskell/core-libraries-committee/issues/252))+  * Add `firstA` and `secondA` to `Data.Bitraversable`. ([CLC proposal #172](https://github.com/haskell/core-libraries-committee/issues/172))+  * Deprecate `GHC.TypeNats.Internal`, `GHC.TypeLits.Internal`, `GHC.ExecutionStack.Internal` ([CLC proposal #217](https://github.com/haskell/core-libraries-committee/issues/217))+  * `System.IO.Error.ioError` and `Control.Exception.ioError` now both carry `HasCallStack` constraints ([CLC proposal #275](https://github.com/haskell/core-libraries-committee/issues/275))+  * Define `Eq1`, `Ord1`, `Show1` and `Read1` instances for basic `Generic` representation types. ([CLC proposal #273](https://github.com/haskell/core-libraries-committee/issues/273))+  * `setNonBlockingMode` will no longer throw an exception when called on a FD associated with a unknown device type. ([CLC proposal #282](https://github.com/haskell/core-libraries-committee/issues/282))+  * Add exception type metadata to default exception handler output.+    ([CLC proposal #231](https://github.com/haskell/core-libraries-committee/issues/231)+    and [CLC proposal #261](https://github.com/haskell/core-libraries-committee/issues/261))+  * The [deprecation process of GHC.Pack](https://gitlab.haskell.org/ghc/ghc/-/issues/21461) has come its term. The module has now been removed from `base`.+  * Propagate HasCallStack from `errorCallWithCallStackException` to exception backtraces, fixing a bug in the implementation of [CLC proposal #164](https://github.com/haskell/core-libraries-committee/issues/164).+  * Annotate re-thrown exceptions with the backtrace as per [CLC proposal #202](https://github.com/haskell/core-libraries-committee/issues/202) (introduces `WhileHandling` and modifies such as `catch` and `onException` accordingly to propagate or rethrow exceptions)+  * Introduced `catchNoPropagate`, `rethrowIO` and `tryWithContext` as part of+      [CLC proposal #202](https://github.com/haskell/core-libraries-committee/issues/202) to+      facilitate *re*throwing exceptions without adding a `WhileHandling`+      context -- if *re*throwing `e`, you don't want to add `WhileHandling e` to+      the context since it will be redundant. These functions are mostly useful+      for libraries that define exception-handling combinators like `catch` and+      `onException`, such as `base`, or the `exceptions` package.+  * Move `Lift ByteArray` and `Lift Fixed` instances into `base` from `template-haskell`. See [CLC proposal #287](https://github.com/haskell/core-libraries-committee/issues/287).+  * Make `Debug.Trace.{traceEventIO,traceMarkerIO}` faster when tracing is disabled. See [CLC proposal #291](https://github.com/haskell/core-libraries-committee/issues/291).+  * The exception messages were improved according to [CLC proposal #285](https://github.com/haskell/core-libraries-committee/issues/285). In particular:+      * Improve the message of the uncaught exception handler+      * Make `displayException (SomeException e) = displayException e`. The+          additional information that is printed when exceptions are surfaced to+          the top-level is added by `uncaughtExceptionHandler`.+      * Get rid of the HasCallStack mechanism manually propagated by `ErrorCall`+          in favour of the more general HasCallStack exception backtrace+          mechanism, to remove duplicate call stacks for uncaught exceptions.+      * Freeze the callstack of `error`, `undefined`, `throwIO`, `ioException`,+          `ioError` to prevent leaking the implementation of these error functions+          into the callstack. -  * Fix races in IOManager (setNumCapabilities,closeFdWith) (#21651)+## 4.20.0.0 *May 2024*+  * Shipped with GHC 9.10.1+  * Introduce `Data.Enum` module exporting both `Enum` and `Bounded`. Note that the export of `Bounded` will be deprecated in a future release ([CLC proposal #208](https://github.com/haskell/core-libraries-committee/issues/208))+  * Deprecate `GHC.Pack` ([#21461](https://gitlab.haskell.org/ghc/ghc/-/issues/21461))+  * Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167))+  * The top-level handler for uncaught exceptions now displays the output of `displayException` rather than `show`  ([CLC proposal #198](https://github.com/haskell/core-libraries-committee/issues/198))+  * Add `permutations` and `permutations1` to `Data.List.NonEmpty` ([CLC proposal #68](https://github.com/haskell/core-libraries-committee/issues/68))+  * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #175](https://github.com/haskell/core-libraries-committee/issues/175))+  * Implement `stimes` for `instance Semigroup (Endo a)` explicitly ([CLC proposal #4](https://github.com/haskell/core-libraries-committee/issues/4))+  * Add `startTimeProfileAtStartup` to `GHC.RTS.Flags` to expose new RTS flag+    `--no-automatic-heap-samples` in the Haskell API ([CLC proposal #243](https://github.com/haskell/core-libraries-committee/issues/243)).+  * Implement `sconcat` for `instance Semigroup Data.Semigroup.First` and `instance Semigroup Data.Monoid.First` explicitly, increasing laziness ([CLC proposal #246](https://github.com/haskell/core-libraries-committee/issues/246))+  * Add laws relating between `Foldable` / `Traversable` with `Bifoldable` / `Bitraversable` ([CLC proposal #205](https://github.com/haskell/core-libraries-committee/issues/205))+  * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))+  * Exceptions can now be decorated with user-defined annotations via `ExceptionContext` ([CLC proposal #200](https://github.com/haskell/core-libraries-committee/issues/200))+  * Exceptions now capture backtrace information via their `ExceptionContext`. GHC+    supports several mechanisms by which backtraces can be collected which can be+    individually enabled and disabled via+    `GHC.Exception.Backtrace.setBacktraceMechanismState` ([CLC proposal #199](https://github.com/haskell/core-libraries-committee/issues/199))+  * Add `HasCallStack` constraint to `Control.Exception.throw{,IO}` ([CLC proposal #201](https://github.com/haskell/core-libraries-committee/issues/201))+  * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/).+  * Fix `withFile`, `withFileBlocking`, and `withBinaryFile` to not incorrectly annotate exceptions raised in wrapped computation. ([CLC proposal #237](https://github.com/haskell/core-libraries-committee/issues/237))+  * Fix `fdIsNonBlocking` to always be `0` for regular files and block devices on unix, regardless of `O_NONBLOCK`+  * Always use `safe` call to `read` for regular files and block devices on unix if the RTS is multi-threaded, regardless of `O_NONBLOCK`.+    ([CLC proposal #166](https://github.com/haskell/core-libraries-committee/issues/166))+  * Export List from Data.List ([CLC proposal #182](https://github.com/haskell/core-libraries-committee/issues/182)).+  * Add `{-# WARNING in "x-data-list-nonempty-unzip" #-}` to `Data.List.NonEmpty.unzip`.+    Use `{-# OPTIONS_GHC -Wno-x-data-list-nonempty-unzip #-}` to disable it.+     ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86)+     and [CLC proposal #258](https://github.com/haskell/core-libraries-committee/issues/258))+  * Add `System.Mem.performMajorGC` ([CLC proposal #230](https://github.com/haskell/core-libraries-committee/issues/230))+  * Fix exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192))+  * `Foreign.C.Error.errnoToIOError` now uses the reentrant `strerror_r` to render system errors when possible ([CLC proposal #249](https://github.com/haskell/core-libraries-committee/issues/249))+  * Implement `many` and `some` methods of `instance Alternative (Compose f g)` explicitly. ([CLC proposal #181](https://github.com/haskell/core-libraries-committee/issues/181))+  * Change the types of the `GHC.Stack.StackEntry.closureType` and `GHC.InfoProv.InfoProv.ipDesc` record fields to use `GHC.Exts.Heap.ClosureType` rather than an `Int`.+    To recover the old value use `fromEnum`. ([CLC proposal #210](https://github.com/haskell/core-libraries-committee/issues/210))+  * The functions `GHC.Exts.dataToTag#` and `GHC.Base.getTag` have had+    their types changed to the following: -  * winio: do not re-translate input when handle is uncooked+    ```haskell+    dataToTag#, getTag+      :: forall {lev :: Levity} (a :: TYPE (BoxedRep lev))+      .  DataToTag a => a -> Int#+    ``` +    In particular, they are now applicable only at some (not all)+    lifted types.  However, if `t` is an algebraic data type (i.e. `t`+    matches a `data` or `data instance` declaration) with all of its+    constructors in scope and the levity of `t` is statically known,+    then the constraint `DataToTag t` can always be solved.+    ([CLC proposal #104](https://github.com/haskell/core-libraries-committee/issues/104))+  * `GHC.Exts` no longer exports the GHC-internal `whereFrom#` primop ([CLC proposal #214](https://github.com/haskell/core-libraries-committee/issues/214))+  * `GHC.InfoProv.InfoProv` now provides a `ipUnitId :: String` field encoding the unit ID of the unit defining the info table ([CLC proposal #214](https://github.com/haskell/core-libraries-committee/issues/214))+  * Add `sortOn` to `Data.List.NonEmpty`+    ([CLC proposal #227](https://github.com/haskell/core-libraries-committee/issues/227))+  * Add more instances for `Compose`: `Fractional`, `RealFrac`, `Floating`, `RealFloat` ([CLC proposal #226](https://github.com/haskell/core-libraries-committee/issues/226))+  * Treat all FDs as "nonblocking" on wasm32 ([CLC proposal #234](https://github.com/haskell/core-libraries-committee/issues/234))+  * Add `HeapByEra`, `eraSelector` and `automaticEraIncrement` to `GHC.RTS.Flags` to+    reflect the new RTS flags: `-he` profiling mode, `-he` selector and `--automatic-era-increment`.+    ([CLC proposal #254](https://github.com/haskell/core-libraries-committee/issues/254))+  * Document that certain modules are unstable and not meant to be consumed by the general public ([CLC proposal #146](https://github.com/haskell/core-libraries-committee/issues/146))+  * Add unaligned `Addr#` primops ([CLC proposal #154](https://github.com/haskell/core-libraries-committee/issues/154))+  * Deprecate `stgDoubleToWord{32,64}` and `stgWord{32,64}ToDouble` in favor of new primops `castDoubleToWord{32,64}#` and `castWord{32,64}ToDouble#` ([CLC proposal #253](https://github.com/haskell/core-libraries-committee/issues/253))+  * Add `unsafeThawByteArray#`, opposite to the existing `unsafeFreezeByteArray#` ([CLC proposal #184](https://github.com/haskell/core-libraries-committee/issues/184))++## 4.19.0.0 *October 2023*+  * Shipped with GHC 9.8.1+  * Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`.+    Use `{-# OPTIONS_GHC -Wno-x-partial #-}` to disable it.+    ([CLC proposal #87](https://github.com/haskell/core-libraries-committee/issues/87) and [#114](https://github.com/haskell/core-libraries-committee/issues/114))+  * Add `fromThreadId :: ThreadId -> Word64` to `GHC.Conc.Sync`, which maps a thread to a per-process-unique identifier ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117))+  * Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110))+  * Mark `maximumBy`/`minimumBy` as `INLINE` improving performance for unpackable+    types significantly.+  * Add INLINABLE pragmas to `generic*` functions in Data.OldList ([CLC proposal #129](https://github.com/haskell/core-libraries-committee/issues/130))+  * Export `getSolo` from `Data.Tuple`.+      ([CLC proposal #113](https://github.com/haskell/core-libraries-committee/issues/113))+  * Add `Type.Reflection.decTypeRep`, `Data.Typeable.decT` and `Data.Typeable.hdecT` equality decisions functions.+      ([CLC proposal #98](https://github.com/haskell/core-libraries-committee/issues/98))+  * Add `Data.Functor.unzip` ([CLC proposal #88](https://github.com/haskell/core-libraries-committee/issues/88))+  * Add `System.Mem.Weak.{get,set}FinalizerExceptionHandler`, which allows the user to set the global handler invoked by when a `Weak` pointer finalizer throws an exception. ([CLC proposal #126](https://github.com/haskell/core-libraries-committee/issues/126))+  * Add `System.Mem.Weak.printToHandleFinalizerExceptionHandler`, which can be used with `setFinalizerExceptionHandler` to print exceptions thrown by finalizers to the given `Handle`. ([CLC proposal #126](https://github.com/haskell/core-libraries-committee/issues/126))+  * Add `Data.List.unsnoc` ([CLC proposal #165](https://github.com/haskell/core-libraries-committee/issues/165))+  * Implement more members of `instance Foldable (Compose f g)` explicitly.+      ([CLC proposal #57](https://github.com/haskell/core-libraries-committee/issues/57))+  * Add `Eq` and `Ord` instances for `SSymbol`, `SChar`, and `SNat`.+      ([CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148))+  * Add `COMPLETE` pragmas to the `TypeRep`, `SSymbol`, `SChar`, and `SNat` pattern synonyms.+      ([CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149))+  * Make `($)` representation polymorphic ([CLC proposal #132](https://github.com/haskell/core-libraries-committee/issues/132))+  * Implement [GHC Proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst),+    adding the class `Unsatisfiable :: ErrorMessage -> TypeError` to `GHC.TypeError`,+    which provides a mechanism for custom type errors that reports the errors in+    a more predictable behaviour than `TypeError`.+  * Add more instances for `Compose`: `Enum`, `Bounded`, `Num`, `Real`, `Integral` ([CLC proposal #160](https://github.com/haskell/core-libraries-committee/issues/160))+  * Make `(&)` representation polymorphic in the return type ([CLC proposal #158](https://github.com/haskell/core-libraries-committee/issues/158))+  * Implement `GHC.IORef.atomicSwapIORef` via a new dedicated primop `atomicSwapMutVar#` ([CLC proposal #139](https://github.com/haskell/core-libraries-committee/issues/139))+  * Change `BufferCodec` to use an unboxed implementation, while providing a compatibility layer using pattern synonyms. ([CLC proposal #134](https://github.com/haskell/core-libraries-committee/issues/134) and [#178](https://github.com/haskell/core-libraries-committee/issues/178))+  * Add nominal role annotations to `SNat` / `SSymbol` / `SChar` ([CLC proposal #170](https://github.com/haskell/core-libraries-committee/issues/170))+  * Make `Semigroup`'s `stimes` specializable. ([CLC proposal #8](https://github.com/haskell/core-libraries-committee/issues/8))+  * Implement `copyBytes`, `fillBytes`, `moveBytes` and `stimes` for `Data.Array.Byte.ByteArray` using primops ([CLC proposal #188](https://github.com/haskell/core-libraries-committee/issues/188))+  * Add rewrite rules for conversion between `Int64` / `Word64` and `Float` / `Double` on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).+  * `Generic` instances for tuples now expose `Unit`, `Tuple2`, `Tuple3`, ..., `Tuple64` as the actual names for tuple type constructors ([GHC proposal #475](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0475-tuple-syntax.rst)).+  * Reject `FilePath`s containing interior `NUL`s ([CLC proposal #144](https://github.com/haskell/core-libraries-committee/issues/144))+  * Add `GHC.JS.Foreign.Callback` module for JavaScript backend ([CLC proposal #150](https://github.com/haskell/core-libraries-committee/issues/150))+  * Generalize the type of `keepAlive#` and `touch#` ([CLC proposal #152](https://github.com/haskell/core-libraries-committee/issues/152))++## 4.18.0.0 *March 2023*+  * Shipped with GHC 9.6.1+  * `Foreign.C.ConstPtr.ConstrPtr` was added to encode `const`-qualified+    pointer types in foreign declarations when using `CApiFFI` extension. ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117))+  * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91))+  * Add `forall a. Functor (p a)` superclass for `Bifunctor p`.+  * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and+    `(,,,,,) a b c d e f`.+  * Exceptions thrown by weak pointer finalizers can now be reported by setting+    a global exception handler, using `System.Mem.Weak.setFinalizerExceptionHandler`.+    The default behaviour is unchanged (exceptions are ignored and not reported).+  * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`+    ([CLC proposal #45](https://github.com/haskell/core-libraries-committee/issues/45))+  * Add `Data.Foldable1` and `Data.Bifoldable1`+    ([CLC proposal #9](https://github.com/haskell/core-libraries-committee/issues/9))+  * Add `applyWhen` to `Data.Function`+    ([CLC proposal #71](https://github.com/haskell/core-libraries-committee/issues/71))+  * Add functions `mapAccumM` and `forAccumM` to `Data.Traversable`+    ([CLC proposal #65](https://github.com/haskell/core-libraries-committee/issues/65))+  * Add default implementation of `(<>)` in terms of `sconcat` and `mempty` in+    terms of `mconcat` ([CLC proposal #61](https://github.com/haskell/core-libraries-committee/issues/61)).+  * `GHC.Conc.Sync.listThreads` was added, allowing the user to list the threads+    (both running and blocked) of the program.+  * `GHC.Conc.Sync.labelThreadByteArray#` was added, allowing the user to specify+    a thread label by way of a `ByteArray#` containing a UTF-8-encoded string.+    The old `GHC.Conc.Sync.labelThread` is now implemented in terms of this+    function.+  * `GHC.Conc.Sync.threadLabel` was added, allowing the user to query the label+    of a given `ThreadId`.+  * Add `inits1` and `tails1` to `Data.List.NonEmpty`+    ([CLC proposal #67](https://github.com/haskell/core-libraries-committee/issues/67))+  * Change default `Ord` implementation of `(>=)`, `(>)`, and `(<)` to use+    `(<=)` instead of `compare` ([CLC proposal #24](https://github.com/haskell/core-libraries-committee/issues/24)).+  * Export `liftA2` from `Prelude`. This means that the entirety of `Applicative`+    is now exported from `Prelude`+    ([CLC proposal #50](https://github.com/haskell/core-libraries-committee/issues/50),+    [the migration+    guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md))+  * Switch to a pure Haskell implementation of `GHC.Unicode`+    ([CLC proposals #59](https://github.com/haskell/core-libraries-committee/issues/59)+    and [#130](https://github.com/haskell/core-libraries-committee/issues/130))+  * Update to [Unicode 15.0.0](https://www.unicode.org/versions/Unicode15.0.0/).+  * Add standard Unicode case predicates `isUpperCase` and `isLowerCase` to+    `GHC.Unicode` and `Data.Char`. These predicates use the standard Unicode+    case properties and are more intuitive than `isUpper` and `isLower`+    ([CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90))+  * Add `Eq` and `Ord` instances for `Generically1`.+  * Relax instances for Functor combinators; put superclass on Class1 and Class2+    to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10),+    [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md))+  * Add `gcdetails_block_fragmentation_bytes` to `GHC.Stats.GCDetails` to track heap fragmentation.+  * `GHC.TypeLits` and `GHC.TypeNats` now export the `natSing`, `symbolSing`,+    and `charSing` methods of `KnownNat`, `KnownSymbol`, and `KnownChar`,+    respectively. They also export the `SNat`, `SSymbol`, and `SChar` types+    that are used in these methods and provide an API to interact with these+    types, per+    [CLC proposal #85](https://github.com/haskell/core-libraries-committee/issues/85).+  * The `Enum` instance of `Down a` now enumerates values in the opposite+    order as the `Enum a` instance ([CLC proposal #51](https://github.com/haskell/core-libraries-committee/issues/51))+  * `Foreign.Marshal.Pool` now uses the RTS internal arena instead of libc+    `malloc` for allocation. It avoids the O(n) overhead of maintaining a list+    of individually allocated pointers as well as freeing each one of them when+    freeing a `Pool` (#14762, #18338)+  * `Type.Reflection.Unsafe` is now marked as unsafe.+  * Add `Data.Typeable.heqT`, a kind-heterogeneous version of+    `Data.Typeable.eqT`+    ([CLC proposal #99](https://github.com/haskell/core-libraries-committee/issues/99))+  * Various declarations GHC's new info-table provenance feature have been+    moved from `GHC.Stack.CCS` to a new `GHC.InfoProv` module:+    * The `InfoProv`, along its `ipName`, `ipDesc`, `ipTyDesc`, `ipLabel`,+      `ipMod`, and `ipLoc` fields, have been moved.+    * `InfoProv` now has additional `ipSrcFile` and `ipSrcSpan` fields. `ipLoc`+      is now a function computed from these fields.+    * The `whereFrom` function has been moved+  * Add functions `traceWith`, `traceShowWith`, `traceEventWith` to+    `Debug.Trace`, per+    [CLC proposal #36](https://github.com/haskell/core-libraries-committee/issues/36).+  * Export `List` from `GHC.List`+    ([CLC proposal #186](https://github.com/haskell/core-libraries-committee/issues/186)).++## 4.17.0.0 *August 2022*++  * Shipped with GHC 9.4.1++  * Add explicitly bidirectional `pattern TypeRep` to `Type.Reflection`.++  * Add `Generically` and `Generically1` to `GHC.Generics` for deriving generic+    instances with `DerivingVia`. `Generically` instances include `Semigroup` and+    `Monoid`. `Generically1` instances: `Functor`, `Applicative`, `Alternative`,+    `Eq1` and `Ord1`.++  * Introduce `GHC.ExecutablePath.executablePath`, which is more robust than+    `getExecutablePath` in cases when the executable has been deleted.++  * Add `Data.Array.Byte` module, providing boxed `ByteArray#` and `MutableByteArray#` wrappers.++  * `fromEnum` for `Natural` now throws an error for any number that cannot be+    repesented exactly by an `Int` (#20291).++  * `returnA` is defined as `Control.Category.id` instead of `arr id`.++  * Added symbolic synonyms for `xor` and shift operators to `Data.Bits`:++    - `.^.` (`xor`),+    - `.>>.` and `!>>.` (`shiftR` and `unsafeShiftR`),+    - `.<<.` and `!<<.` (`shiftL` and `unsafeShiftL`).++    These new operators have the same fixity as the originals.++  * `GHC.Exts` now re-exports `Multiplicity` and `MultMul`.++  * A large number of partial functions in `Data.List` and `Data.List.NonEmpty` now+    have an HasCallStack constraint. Hopefully providing better error messages in case+    they are used in unexpected ways.++  * Fix the `Ord1` instance for `Data.Ord.Down` to reverse sort order.++  * Any Haskell type that wraps a C pointer type has been changed from+    `Ptr ()` to `CUIntPtr`. For typical glibc based platforms, the+    affected type is `CTimer`.++  * Remove instances of `MonadFail` for the `ST` monad (lazy and strict) as per+    the [Core Libraries proposal](https://github.com/haskell/core-libraries-committee/issues/33).+    A [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/no-monadfail-st-inst.md)+    is available.++  * Re-export `augment` and `build` function from `GHC.List`++  * Re-export the `IsList` typeclass from the new `GHC.IsList` module.++  * There's a new special function `withDict` in `GHC.Exts`: ::++        withDict :: forall {rr :: RuntimeRep} cls meth (r :: TYPE rr). WithDict cls meth => meth -> (cls => r) -> r++    where `cls` must be a class containing exactly one method, whose type+    must be `meth`.++    This function converts `meth` to a type class dictionary.+    It removes the need for `unsafeCoerce` in implementation of reflection+    libraries. It should be used with care, because it can introduce+    incoherent instances.++    For example, the `withTypeable` function from the+    `Type.Reflection` module can now be defined as: ::++          withTypeable :: forall k (a :: k) rep (r :: TYPE rep). ()+                       => TypeRep a -> (Typeable a => r) -> r+          withTypeable rep k = withDict @(Typeable a) rep k++    Note that the explicit type application is required, as the call to+    `withDict` would be ambiguous otherwise.++    This replaces the old `GHC.Exts.magicDict`, which required+    an intermediate data type and was less reliable.++  * `Data.Word.Word64` and `Data.Int.Int64` are now always represented by+    `Word64#` and `Int64#`, respectively. Previously on 32-bit platforms these+    were rather represented by `Word#` and `Int#`. See GHC #11953.++  * Add `GHC.TypeError` module to contain functionality related to custom type+    errors. `TypeError` is re-exported from `GHC.TypeLits` for backwards+    compatibility.++  * Comparison constraints in `Data.Type.Ord` (e.g. `<=`) now use the new+    `GHC.TypeError.Assert` type family instead of type equality with `~`.+ ## 4.16.3.0 *May 2022*    * Shipped with GHC 9.2.4 -  * winio: make consoleReadNonBlocking not wait for any events at all.+  * winio: make `consoleReadNonBlocking` not wait for any events at all. -  * winio: Add support to console handles to handleToHANDLE+  * winio: Add support to console handles to `handleToHANDLE`  ## 4.16.2.0 *May 2022*    * Shipped with GHC 9.2.2 -  * Export GHC.Event.Internal on Windows (#21245)+  * Export `GHC.Event.Internal` on Windows (#21245) -  # Documentation Fixes+  * Documentation Fixes  ## 4.16.1.0 *Feb 2022* @@ -87,23 +431,31 @@   * `fromInteger :: Integer -> Float/Double` now consistently round to the     nearest value, with ties to even. -  * The `Data.Int.Int{8,16,32}` (resp. `Data.Word.Word{8,16,32}`) types are now-    represented by their associated fixed-width unlifted types rather than-    `Int#` (resp. `Word#`).-   * Additions to `Data.Bits`:      - Newtypes `And`, `Ior`, `Xor` and `Iff` which wrap their argument,       and whose `Semigroup` instances are defined using `(.&.)`, `(.|.)`, `xor`-      and ```\x y -> complement (x `xor` y)```, respectively.+      and `\x y -> complement (x `xor` y)`, respectively.      - `oneBits :: FiniteBits a => a`, `oneBits = complement zeroBits`. +  * Various folding operations in `GHC.List` are now implemented via strict+    folds:+    - `sum`+    - `product`+    - `maximum`+    - `minimum`+ ## 4.15.0.0 *Feb 2021* +  * Shipped with GHC 9.0.1+   * `openFile` now calls the `open` system call with an `interruptible` FFI     call, ensuring that the call can be interrupted with `SIGINT` on POSIX     systems.++  * Make `openFile` more tolerant of asynchronous exceptions: more care taken+    to release the file descriptor and the read/write lock (#18832)    * Add `hGetContents'`, `getContents'`, and `readFile'` in `System.IO`:     Strict IO variants of `hGetContents`, `getContents`, and `readFile`.
− config.guess 
@@ -1,1754 +0,0 @@-#! /bin/sh-# Attempt to guess a canonical system name.-#   Copyright 1992-2022 Free Software Foundation, Inc.--# shellcheck disable=SC2006,SC2268 # see below for rationale--timestamp='2022-01-09'--# This file is free software; you can redistribute it and/or modify it-# under the terms of the GNU General Public License as published by-# the Free Software Foundation, either version 3 of the License, or-# (at your option) any later version.-#-# This program is distributed in the hope that it will be useful, but-# WITHOUT ANY WARRANTY; without even the implied warranty of-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU-# General Public License for more details.-#-# You should have received a copy of the GNU General Public License-# along with this program; if not, see <https://www.gnu.org/licenses/>.-#-# As a special exception to the GNU General Public License, if you-# distribute this file as part of a program that contains a-# configuration script generated by Autoconf, you may include it under-# the same distribution terms that you use for the rest of that-# program.  This Exception is an additional permission under section 7-# of the GNU General Public License, version 3 ("GPLv3").-#-# Originally written by Per Bothner; maintained since 2000 by Ben Elliston.-#-# You can get the latest version of this script from:-# https://git.savannah.gnu.org/cgit/config.git/plain/config.guess-#-# Please send patches to <config-patches@gnu.org>.---# The "shellcheck disable" line above the timestamp inhibits complaints-# about features and limitations of the classic Bourne shell that were-# superseded or lifted in POSIX.  However, this script identifies a wide-# variety of pre-POSIX systems that do not have POSIX shells at all, and-# even some reasonably current systems (Solaris 10 as case-in-point) still-# have a pre-POSIX /bin/sh.---me=`echo "$0" | sed -e 's,.*/,,'`--usage="\-Usage: $0 [OPTION]--Output the configuration name of the system \`$me' is run on.--Options:-  -h, --help         print this help, then exit-  -t, --time-stamp   print date of last modification, then exit-  -v, --version      print version number, then exit--Report bugs and patches to <config-patches@gnu.org>."--version="\-GNU config.guess ($timestamp)--Originally written by Per Bothner.-Copyright 1992-2022 Free Software Foundation, Inc.--This is free software; see the source for copying conditions.  There is NO-warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."--help="-Try \`$me --help' for more information."--# Parse command line-while test $# -gt 0 ; do-  case $1 in-    --time-stamp | --time* | -t )-       echo "$timestamp" ; exit ;;-    --version | -v )-       echo "$version" ; exit ;;-    --help | --h* | -h )-       echo "$usage"; exit ;;-    -- )     # Stop option processing-       shift; break ;;-    - )	# Use stdin as input.-       break ;;-    -* )-       echo "$me: invalid option $1$help" >&2-       exit 1 ;;-    * )-       break ;;-  esac-done--if test $# != 0; then-  echo "$me: too many arguments$help" >&2-  exit 1-fi--# Just in case it came from the environment.-GUESS=--# CC_FOR_BUILD -- compiler used by this script. Note that the use of a-# compiler to aid in system detection is discouraged as it requires-# temporary files to be created and, as you can see below, it is a-# headache to deal with in a portable fashion.--# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still-# use `HOST_CC' if defined, but it is deprecated.--# Portable tmp directory creation inspired by the Autoconf team.--tmp=-# shellcheck disable=SC2172-trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15--set_cc_for_build() {-    # prevent multiple calls if $tmp is already set-    test "$tmp" && return 0-    : "${TMPDIR=/tmp}"-    # shellcheck disable=SC2039,SC3028-    { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||-	{ test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir "$tmp" 2>/dev/null) ; } ||-	{ tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } ||-	{ echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; }-    dummy=$tmp/dummy-    case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in-	,,)    echo "int x;" > "$dummy.c"-	       for driver in cc gcc c89 c99 ; do-		   if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then-		       CC_FOR_BUILD=$driver-		       break-		   fi-	       done-	       if test x"$CC_FOR_BUILD" = x ; then-		   CC_FOR_BUILD=no_compiler_found-	       fi-	       ;;-	,,*)   CC_FOR_BUILD=$CC ;;-	,*,*)  CC_FOR_BUILD=$HOST_CC ;;-    esac-}--# This is needed to find uname on a Pyramid OSx when run in the BSD universe.-# (ghazi@noc.rutgers.edu 1994-08-24)-if test -f /.attbin/uname ; then-	PATH=$PATH:/.attbin ; export PATH-fi--UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown-UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown-UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown-UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown--case $UNAME_SYSTEM in-Linux|GNU|GNU/*)-	LIBC=unknown--	set_cc_for_build-	cat <<-EOF > "$dummy.c"-	#include <features.h>-	#if defined(__UCLIBC__)-	LIBC=uclibc-	#elif defined(__dietlibc__)-	LIBC=dietlibc-	#elif defined(__GLIBC__)-	LIBC=gnu-	#else-	#include <stdarg.h>-	/* First heuristic to detect musl libc.  */-	#ifdef __DEFINED_va_list-	LIBC=musl-	#endif-	#endif-	EOF-	cc_set_libc=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'`-	eval "$cc_set_libc"--	# Second heuristic to detect musl libc.-	if [ "$LIBC" = unknown ] &&-	   command -v ldd >/dev/null &&-	   ldd --version 2>&1 | grep -q ^musl; then-		LIBC=musl-	fi--	# If the system lacks a compiler, then just pick glibc.-	# We could probably try harder.-	if [ "$LIBC" = unknown ]; then-		LIBC=gnu-	fi-	;;-esac--# Note: order is significant - the case branches are not exclusive.--case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in-    *:NetBSD:*:*)-	# NetBSD (nbsd) targets should (where applicable) match one or-	# more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*,-	# *-*-netbsdecoff* and *-*-netbsd*.  For targets that recently-	# switched to ELF, *-*-netbsd* would select the old-	# object file format.  This provides both forward-	# compatibility and a consistent mechanism for selecting the-	# object file format.-	#-	# Note: NetBSD doesn't particularly care about the vendor-	# portion of the name.  We always set it to "unknown".-	UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \-	    /sbin/sysctl -n hw.machine_arch 2>/dev/null || \-	    /usr/sbin/sysctl -n hw.machine_arch 2>/dev/null || \-	    echo unknown)`-	case $UNAME_MACHINE_ARCH in-	    aarch64eb) machine=aarch64_be-unknown ;;-	    armeb) machine=armeb-unknown ;;-	    arm*) machine=arm-unknown ;;-	    sh3el) machine=shl-unknown ;;-	    sh3eb) machine=sh-unknown ;;-	    sh5el) machine=sh5le-unknown ;;-	    earmv*)-		arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'`-		endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'`-		machine=${arch}${endian}-unknown-		;;-	    *) machine=$UNAME_MACHINE_ARCH-unknown ;;-	esac-	# The Operating System including object format, if it has switched-	# to ELF recently (or will in the future) and ABI.-	case $UNAME_MACHINE_ARCH in-	    earm*)-		os=netbsdelf-		;;-	    arm*|i386|m68k|ns32k|sh3*|sparc|vax)-		set_cc_for_build-		if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \-			| grep -q __ELF__-		then-		    # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).-		    # Return netbsd for either.  FIX?-		    os=netbsd-		else-		    os=netbsdelf-		fi-		;;-	    *)-		os=netbsd-		;;-	esac-	# Determine ABI tags.-	case $UNAME_MACHINE_ARCH in-	    earm*)-		expr='s/^earmv[0-9]/-eabi/;s/eb$//'-		abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"`-		;;-	esac-	# The OS release-	# Debian GNU/NetBSD machines have a different userland, and-	# thus, need a distinct triplet. However, they do not need-	# kernel version information, so it can be replaced with a-	# suitable tag, in the style of linux-gnu.-	case $UNAME_VERSION in-	    Debian*)-		release='-gnu'-		;;-	    *)-		release=`echo "$UNAME_RELEASE" | sed -e 's/[-_].*//' | cut -d. -f1,2`-		;;-	esac-	# Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:-	# contains redundant information, the shorter form:-	# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.-	GUESS=$machine-${os}${release}${abi-}-	;;-    *:Bitrig:*:*)-	UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'`-	GUESS=$UNAME_MACHINE_ARCH-unknown-bitrig$UNAME_RELEASE-	;;-    *:OpenBSD:*:*)-	UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`-	GUESS=$UNAME_MACHINE_ARCH-unknown-openbsd$UNAME_RELEASE-	;;-    *:SecBSD:*:*)-	UNAME_MACHINE_ARCH=`arch | sed 's/SecBSD.//'`-	GUESS=$UNAME_MACHINE_ARCH-unknown-secbsd$UNAME_RELEASE-	;;-    *:LibertyBSD:*:*)-	UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'`-	GUESS=$UNAME_MACHINE_ARCH-unknown-libertybsd$UNAME_RELEASE-	;;-    *:MidnightBSD:*:*)-	GUESS=$UNAME_MACHINE-unknown-midnightbsd$UNAME_RELEASE-	;;-    *:ekkoBSD:*:*)-	GUESS=$UNAME_MACHINE-unknown-ekkobsd$UNAME_RELEASE-	;;-    *:SolidBSD:*:*)-	GUESS=$UNAME_MACHINE-unknown-solidbsd$UNAME_RELEASE-	;;-    *:OS108:*:*)-	GUESS=$UNAME_MACHINE-unknown-os108_$UNAME_RELEASE-	;;-    macppc:MirBSD:*:*)-	GUESS=powerpc-unknown-mirbsd$UNAME_RELEASE-	;;-    *:MirBSD:*:*)-	GUESS=$UNAME_MACHINE-unknown-mirbsd$UNAME_RELEASE-	;;-    *:Sortix:*:*)-	GUESS=$UNAME_MACHINE-unknown-sortix-	;;-    *:Twizzler:*:*)-	GUESS=$UNAME_MACHINE-unknown-twizzler-	;;-    *:Redox:*:*)-	GUESS=$UNAME_MACHINE-unknown-redox-	;;-    mips:OSF1:*.*)-	GUESS=mips-dec-osf1-	;;-    alpha:OSF1:*:*)-	# Reset EXIT trap before exiting to avoid spurious non-zero exit code.-	trap '' 0-	case $UNAME_RELEASE in-	*4.0)-		UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`-		;;-	*5.*)-		UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`-		;;-	esac-	# According to Compaq, /usr/sbin/psrinfo has been available on-	# OSF/1 and Tru64 systems produced since 1995.  I hope that-	# covers most systems running today.  This code pipes the CPU-	# types through head -n 1, so we only detect the type of CPU 0.-	ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^  The alpha \(.*\) processor.*$/\1/p' | head -n 1`-	case $ALPHA_CPU_TYPE in-	    "EV4 (21064)")-		UNAME_MACHINE=alpha ;;-	    "EV4.5 (21064)")-		UNAME_MACHINE=alpha ;;-	    "LCA4 (21066/21068)")-		UNAME_MACHINE=alpha ;;-	    "EV5 (21164)")-		UNAME_MACHINE=alphaev5 ;;-	    "EV5.6 (21164A)")-		UNAME_MACHINE=alphaev56 ;;-	    "EV5.6 (21164PC)")-		UNAME_MACHINE=alphapca56 ;;-	    "EV5.7 (21164PC)")-		UNAME_MACHINE=alphapca57 ;;-	    "EV6 (21264)")-		UNAME_MACHINE=alphaev6 ;;-	    "EV6.7 (21264A)")-		UNAME_MACHINE=alphaev67 ;;-	    "EV6.8CB (21264C)")-		UNAME_MACHINE=alphaev68 ;;-	    "EV6.8AL (21264B)")-		UNAME_MACHINE=alphaev68 ;;-	    "EV6.8CX (21264D)")-		UNAME_MACHINE=alphaev68 ;;-	    "EV6.9A (21264/EV69A)")-		UNAME_MACHINE=alphaev69 ;;-	    "EV7 (21364)")-		UNAME_MACHINE=alphaev7 ;;-	    "EV7.9 (21364A)")-		UNAME_MACHINE=alphaev79 ;;-	esac-	# A Pn.n version is a patched version.-	# A Vn.n version is a released version.-	# A Tn.n version is a released field test version.-	# A Xn.n version is an unreleased experimental baselevel.-	# 1.2 uses "1.2" for uname -r.-	OSF_REL=`echo "$UNAME_RELEASE" | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz`-	GUESS=$UNAME_MACHINE-dec-osf$OSF_REL-	;;-    Amiga*:UNIX_System_V:4.0:*)-	GUESS=m68k-unknown-sysv4-	;;-    *:[Aa]miga[Oo][Ss]:*:*)-	GUESS=$UNAME_MACHINE-unknown-amigaos-	;;-    *:[Mm]orph[Oo][Ss]:*:*)-	GUESS=$UNAME_MACHINE-unknown-morphos-	;;-    *:OS/390:*:*)-	GUESS=i370-ibm-openedition-	;;-    *:z/VM:*:*)-	GUESS=s390-ibm-zvmoe-	;;-    *:OS400:*:*)-	GUESS=powerpc-ibm-os400-	;;-    arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)-	GUESS=arm-acorn-riscix$UNAME_RELEASE-	;;-    arm*:riscos:*:*|arm*:RISCOS:*:*)-	GUESS=arm-unknown-riscos-	;;-    SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)-	GUESS=hppa1.1-hitachi-hiuxmpp-	;;-    Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)-	# akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.-	case `(/bin/universe) 2>/dev/null` in-	    att) GUESS=pyramid-pyramid-sysv3 ;;-	    *)   GUESS=pyramid-pyramid-bsd   ;;-	esac-	;;-    NILE*:*:*:dcosx)-	GUESS=pyramid-pyramid-svr4-	;;-    DRS?6000:unix:4.0:6*)-	GUESS=sparc-icl-nx6-	;;-    DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)-	case `/usr/bin/uname -p` in-	    sparc) GUESS=sparc-icl-nx7 ;;-	esac-	;;-    s390x:SunOS:*:*)-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`-	GUESS=$UNAME_MACHINE-ibm-solaris2$SUN_REL-	;;-    sun4H:SunOS:5.*:*)-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`-	GUESS=sparc-hal-solaris2$SUN_REL-	;;-    sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`-	GUESS=sparc-sun-solaris2$SUN_REL-	;;-    i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*)-	GUESS=i386-pc-auroraux$UNAME_RELEASE-	;;-    i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)-	set_cc_for_build-	SUN_ARCH=i386-	# If there is a compiler, see if it is configured for 64-bit objects.-	# Note that the Sun cc does not turn __LP64__ into 1 like gcc does.-	# This test works for both compilers.-	if test "$CC_FOR_BUILD" != no_compiler_found; then-	    if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \-		(CCOPTS="" $CC_FOR_BUILD -m64 -E - 2>/dev/null) | \-		grep IS_64BIT_ARCH >/dev/null-	    then-		SUN_ARCH=x86_64-	    fi-	fi-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`-	GUESS=$SUN_ARCH-pc-solaris2$SUN_REL-	;;-    sun4*:SunOS:6*:*)-	# According to config.sub, this is the proper way to canonicalize-	# SunOS6.  Hard to guess exactly what SunOS6 will be like, but-	# it's likely to be more like Solaris than SunOS4.-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`-	GUESS=sparc-sun-solaris3$SUN_REL-	;;-    sun4*:SunOS:*:*)-	case `/usr/bin/arch -k` in-	    Series*|S4*)-		UNAME_RELEASE=`uname -v`-		;;-	esac-	# Japanese Language versions have a version number like `4.1.3-JL'.-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'`-	GUESS=sparc-sun-sunos$SUN_REL-	;;-    sun3*:SunOS:*:*)-	GUESS=m68k-sun-sunos$UNAME_RELEASE-	;;-    sun*:*:4.2BSD:*)-	UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`-	test "x$UNAME_RELEASE" = x && UNAME_RELEASE=3-	case `/bin/arch` in-	    sun3)-		GUESS=m68k-sun-sunos$UNAME_RELEASE-		;;-	    sun4)-		GUESS=sparc-sun-sunos$UNAME_RELEASE-		;;-	esac-	;;-    aushp:SunOS:*:*)-	GUESS=sparc-auspex-sunos$UNAME_RELEASE-	;;-    # The situation for MiNT is a little confusing.  The machine name-    # can be virtually everything (everything which is not-    # "atarist" or "atariste" at least should have a processor-    # > m68000).  The system name ranges from "MiNT" over "FreeMiNT"-    # to the lowercase version "mint" (or "freemint").  Finally-    # the system name "TOS" denotes a system which is actually not-    # MiNT.  But MiNT is downward compatible to TOS, so this should-    # be no problem.-    atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)-	GUESS=m68k-atari-mint$UNAME_RELEASE-	;;-    atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)-	GUESS=m68k-atari-mint$UNAME_RELEASE-	;;-    *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)-	GUESS=m68k-atari-mint$UNAME_RELEASE-	;;-    milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)-	GUESS=m68k-milan-mint$UNAME_RELEASE-	;;-    hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)-	GUESS=m68k-hades-mint$UNAME_RELEASE-	;;-    *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)-	GUESS=m68k-unknown-mint$UNAME_RELEASE-	;;-    m68k:machten:*:*)-	GUESS=m68k-apple-machten$UNAME_RELEASE-	;;-    powerpc:machten:*:*)-	GUESS=powerpc-apple-machten$UNAME_RELEASE-	;;-    RISC*:Mach:*:*)-	GUESS=mips-dec-mach_bsd4.3-	;;-    RISC*:ULTRIX:*:*)-	GUESS=mips-dec-ultrix$UNAME_RELEASE-	;;-    VAX*:ULTRIX*:*:*)-	GUESS=vax-dec-ultrix$UNAME_RELEASE-	;;-    2020:CLIX:*:* | 2430:CLIX:*:*)-	GUESS=clipper-intergraph-clix$UNAME_RELEASE-	;;-    mips:*:*:UMIPS | mips:*:*:RISCos)-	set_cc_for_build-	sed 's/^	//' << EOF > "$dummy.c"-#ifdef __cplusplus-#include <stdio.h>  /* for printf() prototype */-	int main (int argc, char *argv[]) {-#else-	int main (argc, argv) int argc; char *argv[]; {-#endif-	#if defined (host_mips) && defined (MIPSEB)-	#if defined (SYSTYPE_SYSV)-	  printf ("mips-mips-riscos%ssysv\\n", argv[1]); exit (0);-	#endif-	#if defined (SYSTYPE_SVR4)-	  printf ("mips-mips-riscos%ssvr4\\n", argv[1]); exit (0);-	#endif-	#if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)-	  printf ("mips-mips-riscos%sbsd\\n", argv[1]); exit (0);-	#endif-	#endif-	  exit (-1);-	}-EOF-	$CC_FOR_BUILD -o "$dummy" "$dummy.c" &&-	  dummyarg=`echo "$UNAME_RELEASE" | sed -n 's/\([0-9]*\).*/\1/p'` &&-	  SYSTEM_NAME=`"$dummy" "$dummyarg"` &&-	    { echo "$SYSTEM_NAME"; exit; }-	GUESS=mips-mips-riscos$UNAME_RELEASE-	;;-    Motorola:PowerMAX_OS:*:*)-	GUESS=powerpc-motorola-powermax-	;;-    Motorola:*:4.3:PL8-*)-	GUESS=powerpc-harris-powermax-	;;-    Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)-	GUESS=powerpc-harris-powermax-	;;-    Night_Hawk:Power_UNIX:*:*)-	GUESS=powerpc-harris-powerunix-	;;-    m88k:CX/UX:7*:*)-	GUESS=m88k-harris-cxux7-	;;-    m88k:*:4*:R4*)-	GUESS=m88k-motorola-sysv4-	;;-    m88k:*:3*:R3*)-	GUESS=m88k-motorola-sysv3-	;;-    AViiON:dgux:*:*)-	# DG/UX returns AViiON for all architectures-	UNAME_PROCESSOR=`/usr/bin/uname -p`-	if test "$UNAME_PROCESSOR" = mc88100 || test "$UNAME_PROCESSOR" = mc88110-	then-	    if test "$TARGET_BINARY_INTERFACE"x = m88kdguxelfx || \-	       test "$TARGET_BINARY_INTERFACE"x = x-	    then-		GUESS=m88k-dg-dgux$UNAME_RELEASE-	    else-		GUESS=m88k-dg-dguxbcs$UNAME_RELEASE-	    fi-	else-	    GUESS=i586-dg-dgux$UNAME_RELEASE-	fi-	;;-    M88*:DolphinOS:*:*)	# DolphinOS (SVR3)-	GUESS=m88k-dolphin-sysv3-	;;-    M88*:*:R3*:*)-	# Delta 88k system running SVR3-	GUESS=m88k-motorola-sysv3-	;;-    XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)-	GUESS=m88k-tektronix-sysv3-	;;-    Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)-	GUESS=m68k-tektronix-bsd-	;;-    *:IRIX*:*:*)-	IRIX_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/g'`-	GUESS=mips-sgi-irix$IRIX_REL-	;;-    ????????:AIX?:[12].1:2)   # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.-	GUESS=romp-ibm-aix    # uname -m gives an 8 hex-code CPU id-	;;                    # Note that: echo "'`uname -s`'" gives 'AIX '-    i*86:AIX:*:*)-	GUESS=i386-ibm-aix-	;;-    ia64:AIX:*:*)-	if test -x /usr/bin/oslevel ; then-		IBM_REV=`/usr/bin/oslevel`-	else-		IBM_REV=$UNAME_VERSION.$UNAME_RELEASE-	fi-	GUESS=$UNAME_MACHINE-ibm-aix$IBM_REV-	;;-    *:AIX:2:3)-	if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then-		set_cc_for_build-		sed 's/^		//' << EOF > "$dummy.c"-		#include <sys/systemcfg.h>--		main()-			{-			if (!__power_pc())-				exit(1);-			puts("powerpc-ibm-aix3.2.5");-			exit(0);-			}-EOF-		if $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"`-		then-			GUESS=$SYSTEM_NAME-		else-			GUESS=rs6000-ibm-aix3.2.5-		fi-	elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then-		GUESS=rs6000-ibm-aix3.2.4-	else-		GUESS=rs6000-ibm-aix3.2-	fi-	;;-    *:AIX:*:[4567])-	IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`-	if /usr/sbin/lsattr -El "$IBM_CPU_ID" | grep ' POWER' >/dev/null 2>&1; then-		IBM_ARCH=rs6000-	else-		IBM_ARCH=powerpc-	fi-	if test -x /usr/bin/lslpp ; then-		IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | \-			   awk -F: '{ print $3 }' | sed s/[0-9]*$/0/`-	else-		IBM_REV=$UNAME_VERSION.$UNAME_RELEASE-	fi-	GUESS=$IBM_ARCH-ibm-aix$IBM_REV-	;;-    *:AIX:*:*)-	GUESS=rs6000-ibm-aix-	;;-    ibmrt:4.4BSD:*|romp-ibm:4.4BSD:*)-	GUESS=romp-ibm-bsd4.4-	;;-    ibmrt:*BSD:*|romp-ibm:BSD:*)            # covers RT/PC BSD and-	GUESS=romp-ibm-bsd$UNAME_RELEASE    # 4.3 with uname added to-	;;                                  # report: romp-ibm BSD 4.3-    *:BOSX:*:*)-	GUESS=rs6000-bull-bosx-	;;-    DPX/2?00:B.O.S.:*:*)-	GUESS=m68k-bull-sysv3-	;;-    9000/[34]??:4.3bsd:1.*:*)-	GUESS=m68k-hp-bsd-	;;-    hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)-	GUESS=m68k-hp-bsd4.4-	;;-    9000/[34678]??:HP-UX:*:*)-	HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'`-	case $UNAME_MACHINE in-	    9000/31?)            HP_ARCH=m68000 ;;-	    9000/[34]??)         HP_ARCH=m68k ;;-	    9000/[678][0-9][0-9])-		if test -x /usr/bin/getconf; then-		    sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`-		    sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`-		    case $sc_cpu_version in-		      523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0-		      528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1-		      532)                      # CPU_PA_RISC2_0-			case $sc_kernel_bits in-			  32) HP_ARCH=hppa2.0n ;;-			  64) HP_ARCH=hppa2.0w ;;-			  '') HP_ARCH=hppa2.0 ;;   # HP-UX 10.20-			esac ;;-		    esac-		fi-		if test "$HP_ARCH" = ""; then-		    set_cc_for_build-		    sed 's/^		//' << EOF > "$dummy.c"--		#define _HPUX_SOURCE-		#include <stdlib.h>-		#include <unistd.h>--		int main ()-		{-		#if defined(_SC_KERNEL_BITS)-		    long bits = sysconf(_SC_KERNEL_BITS);-		#endif-		    long cpu  = sysconf (_SC_CPU_VERSION);--		    switch (cpu)-			{-			case CPU_PA_RISC1_0: puts ("hppa1.0"); break;-			case CPU_PA_RISC1_1: puts ("hppa1.1"); break;-			case CPU_PA_RISC2_0:-		#if defined(_SC_KERNEL_BITS)-			    switch (bits)-				{-				case 64: puts ("hppa2.0w"); break;-				case 32: puts ("hppa2.0n"); break;-				default: puts ("hppa2.0"); break;-				} break;-		#else  /* !defined(_SC_KERNEL_BITS) */-			    puts ("hppa2.0"); break;-		#endif-			default: puts ("hppa1.0"); break;-			}-		    exit (0);-		}-EOF-		    (CCOPTS="" $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null) && HP_ARCH=`"$dummy"`-		    test -z "$HP_ARCH" && HP_ARCH=hppa-		fi ;;-	esac-	if test "$HP_ARCH" = hppa2.0w-	then-	    set_cc_for_build--	    # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating-	    # 32-bit code.  hppa64-hp-hpux* has the same kernel and a compiler-	    # generating 64-bit code.  GNU and HP use different nomenclature:-	    #-	    # $ CC_FOR_BUILD=cc ./config.guess-	    # => hppa2.0w-hp-hpux11.23-	    # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess-	    # => hppa64-hp-hpux11.23--	    if echo __LP64__ | (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) |-		grep -q __LP64__-	    then-		HP_ARCH=hppa2.0w-	    else-		HP_ARCH=hppa64-	    fi-	fi-	GUESS=$HP_ARCH-hp-hpux$HPUX_REV-	;;-    ia64:HP-UX:*:*)-	HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'`-	GUESS=ia64-hp-hpux$HPUX_REV-	;;-    3050*:HI-UX:*:*)-	set_cc_for_build-	sed 's/^	//' << EOF > "$dummy.c"-	#include <unistd.h>-	int-	main ()-	{-	  long cpu = sysconf (_SC_CPU_VERSION);-	  /* The order matters, because CPU_IS_HP_MC68K erroneously returns-	     true for CPU_PA_RISC1_0.  CPU_IS_PA_RISC returns correct-	     results, however.  */-	  if (CPU_IS_PA_RISC (cpu))-	    {-	      switch (cpu)-		{-		  case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;-		  case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;-		  case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;-		  default: puts ("hppa-hitachi-hiuxwe2"); break;-		}-	    }-	  else if (CPU_IS_HP_MC68K (cpu))-	    puts ("m68k-hitachi-hiuxwe2");-	  else puts ("unknown-hitachi-hiuxwe2");-	  exit (0);-	}-EOF-	$CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` &&-		{ echo "$SYSTEM_NAME"; exit; }-	GUESS=unknown-hitachi-hiuxwe2-	;;-    9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:*)-	GUESS=hppa1.1-hp-bsd-	;;-    9000/8??:4.3bsd:*:*)-	GUESS=hppa1.0-hp-bsd-	;;-    *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)-	GUESS=hppa1.0-hp-mpeix-	;;-    hp7??:OSF1:*:* | hp8?[79]:OSF1:*:*)-	GUESS=hppa1.1-hp-osf-	;;-    hp8??:OSF1:*:*)-	GUESS=hppa1.0-hp-osf-	;;-    i*86:OSF1:*:*)-	if test -x /usr/sbin/sysversion ; then-	    GUESS=$UNAME_MACHINE-unknown-osf1mk-	else-	    GUESS=$UNAME_MACHINE-unknown-osf1-	fi-	;;-    parisc*:Lites*:*:*)-	GUESS=hppa1.1-hp-lites-	;;-    C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)-	GUESS=c1-convex-bsd-	;;-    C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)-	if getsysinfo -f scalar_acc-	then echo c32-convex-bsd-	else echo c2-convex-bsd-	fi-	exit ;;-    C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)-	GUESS=c34-convex-bsd-	;;-    C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)-	GUESS=c38-convex-bsd-	;;-    C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)-	GUESS=c4-convex-bsd-	;;-    CRAY*Y-MP:*:*:*)-	CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'`-	GUESS=ymp-cray-unicos$CRAY_REL-	;;-    CRAY*[A-Z]90:*:*:*)-	echo "$UNAME_MACHINE"-cray-unicos"$UNAME_RELEASE" \-	| sed -e 's/CRAY.*\([A-Z]90\)/\1/' \-	      -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \-	      -e 's/\.[^.]*$/.X/'-	exit ;;-    CRAY*TS:*:*:*)-	CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'`-	GUESS=t90-cray-unicos$CRAY_REL-	;;-    CRAY*T3E:*:*:*)-	CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'`-	GUESS=alphaev5-cray-unicosmk$CRAY_REL-	;;-    CRAY*SV1:*:*:*)-	CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'`-	GUESS=sv1-cray-unicos$CRAY_REL-	;;-    *:UNICOS/mp:*:*)-	CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'`-	GUESS=craynv-cray-unicosmp$CRAY_REL-	;;-    F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)-	FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz`-	FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'`-	FUJITSU_REL=`echo "$UNAME_RELEASE" | sed -e 's/ /_/'`-	GUESS=${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}-	;;-    5000:UNIX_System_V:4.*:*)-	FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'`-	FUJITSU_REL=`echo "$UNAME_RELEASE" | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'`-	GUESS=sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}-	;;-    i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)-	GUESS=$UNAME_MACHINE-pc-bsdi$UNAME_RELEASE-	;;-    sparc*:BSD/OS:*:*)-	GUESS=sparc-unknown-bsdi$UNAME_RELEASE-	;;-    *:BSD/OS:*:*)-	GUESS=$UNAME_MACHINE-unknown-bsdi$UNAME_RELEASE-	;;-    arm:FreeBSD:*:*)-	UNAME_PROCESSOR=`uname -p`-	set_cc_for_build-	if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \-	    | grep -q __ARM_PCS_VFP-	then-	    FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'`-	    GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabi-	else-	    FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'`-	    GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabihf-	fi-	;;-    *:FreeBSD:*:*)-	UNAME_PROCESSOR=`/usr/bin/uname -p`-	case $UNAME_PROCESSOR in-	    amd64)-		UNAME_PROCESSOR=x86_64 ;;-	    i386)-		UNAME_PROCESSOR=i586 ;;-	esac-	FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'`-	GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-	;;-    i*:CYGWIN*:*)-	GUESS=$UNAME_MACHINE-pc-cygwin-	;;-    *:MINGW64*:*)-	GUESS=$UNAME_MACHINE-pc-mingw64-	;;-    *:MINGW*:*)-	GUESS=$UNAME_MACHINE-pc-mingw32-	;;-    *:MSYS*:*)-	GUESS=$UNAME_MACHINE-pc-msys-	;;-    i*:PW*:*)-	GUESS=$UNAME_MACHINE-pc-pw32-	;;-    *:SerenityOS:*:*)-        GUESS=$UNAME_MACHINE-pc-serenity-        ;;-    *:Interix*:*)-	case $UNAME_MACHINE in-	    x86)-		GUESS=i586-pc-interix$UNAME_RELEASE-		;;-	    authenticamd | genuineintel | EM64T)-		GUESS=x86_64-unknown-interix$UNAME_RELEASE-		;;-	    IA64)-		GUESS=ia64-unknown-interix$UNAME_RELEASE-		;;-	esac ;;-    i*:UWIN*:*)-	GUESS=$UNAME_MACHINE-pc-uwin-	;;-    amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)-	GUESS=x86_64-pc-cygwin-	;;-    prep*:SunOS:5.*:*)-	SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`-	GUESS=powerpcle-unknown-solaris2$SUN_REL-	;;-    *:GNU:*:*)-	# the GNU system-	GNU_ARCH=`echo "$UNAME_MACHINE" | sed -e 's,[-/].*$,,'`-	GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's,/.*$,,'`-	GUESS=$GNU_ARCH-unknown-$LIBC$GNU_REL-	;;-    *:GNU/*:*:*)-	# other systems with GNU libc and userland-	GNU_SYS=`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"`-	GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'`-	GUESS=$UNAME_MACHINE-unknown-$GNU_SYS$GNU_REL-$LIBC-	;;-    *:Minix:*:*)-	GUESS=$UNAME_MACHINE-unknown-minix-	;;-    aarch64:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    aarch64_be:Linux:*:*)-	UNAME_MACHINE=aarch64_be-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    alpha:Linux:*:*)-	case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' /proc/cpuinfo 2>/dev/null` in-	  EV5)   UNAME_MACHINE=alphaev5 ;;-	  EV56)  UNAME_MACHINE=alphaev56 ;;-	  PCA56) UNAME_MACHINE=alphapca56 ;;-	  PCA57) UNAME_MACHINE=alphapca56 ;;-	  EV6)   UNAME_MACHINE=alphaev6 ;;-	  EV67)  UNAME_MACHINE=alphaev67 ;;-	  EV68*) UNAME_MACHINE=alphaev68 ;;-	esac-	objdump --private-headers /bin/sh | grep -q ld.so.1-	if test "$?" = 0 ; then LIBC=gnulibc1 ; fi-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    arc:Linux:*:* | arceb:Linux:*:* | arc32:Linux:*:* | arc64:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    arm*:Linux:*:*)-	set_cc_for_build-	if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \-	    | grep -q __ARM_EABI__-	then-	    GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	else-	    if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \-		| grep -q __ARM_PCS_VFP-	    then-		GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabi-	    else-		GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabihf-	    fi-	fi-	;;-    avr32*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    cris:Linux:*:*)-	GUESS=$UNAME_MACHINE-axis-linux-$LIBC-	;;-    crisv32:Linux:*:*)-	GUESS=$UNAME_MACHINE-axis-linux-$LIBC-	;;-    e2k:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    frv:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    hexagon:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    i*86:Linux:*:*)-	GUESS=$UNAME_MACHINE-pc-linux-$LIBC-	;;-    ia64:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    k1om:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    loongarch32:Linux:*:* | loongarch64:Linux:*:* | loongarchx32:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    m32r*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    m68*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    mips:Linux:*:* | mips64:Linux:*:*)-	set_cc_for_build-	IS_GLIBC=0-	test x"${LIBC}" = xgnu && IS_GLIBC=1-	sed 's/^	//' << EOF > "$dummy.c"-	#undef CPU-	#undef mips-	#undef mipsel-	#undef mips64-	#undef mips64el-	#if ${IS_GLIBC} && defined(_ABI64)-	LIBCABI=gnuabi64-	#else-	#if ${IS_GLIBC} && defined(_ABIN32)-	LIBCABI=gnuabin32-	#else-	LIBCABI=${LIBC}-	#endif-	#endif--	#if ${IS_GLIBC} && defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6-	CPU=mipsisa64r6-	#else-	#if ${IS_GLIBC} && !defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6-	CPU=mipsisa32r6-	#else-	#if defined(__mips64)-	CPU=mips64-	#else-	CPU=mips-	#endif-	#endif-	#endif--	#if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)-	MIPS_ENDIAN=el-	#else-	#if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)-	MIPS_ENDIAN=-	#else-	MIPS_ENDIAN=-	#endif-	#endif-EOF-	cc_set_vars=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU\|^MIPS_ENDIAN\|^LIBCABI'`-	eval "$cc_set_vars"-	test "x$CPU" != x && { echo "$CPU${MIPS_ENDIAN}-unknown-linux-$LIBCABI"; exit; }-	;;-    mips64el:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    openrisc*:Linux:*:*)-	GUESS=or1k-unknown-linux-$LIBC-	;;-    or32:Linux:*:* | or1k*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    padre:Linux:*:*)-	GUESS=sparc-unknown-linux-$LIBC-	;;-    parisc64:Linux:*:* | hppa64:Linux:*:*)-	GUESS=hppa64-unknown-linux-$LIBC-	;;-    parisc:Linux:*:* | hppa:Linux:*:*)-	# Look for CPU level-	case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in-	  PA7*) GUESS=hppa1.1-unknown-linux-$LIBC ;;-	  PA8*) GUESS=hppa2.0-unknown-linux-$LIBC ;;-	  *)    GUESS=hppa-unknown-linux-$LIBC ;;-	esac-	;;-    ppc64:Linux:*:*)-	GUESS=powerpc64-unknown-linux-$LIBC-	;;-    ppc:Linux:*:*)-	GUESS=powerpc-unknown-linux-$LIBC-	;;-    ppc64le:Linux:*:*)-	GUESS=powerpc64le-unknown-linux-$LIBC-	;;-    ppcle:Linux:*:*)-	GUESS=powerpcle-unknown-linux-$LIBC-	;;-    riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    s390:Linux:*:* | s390x:Linux:*:*)-	GUESS=$UNAME_MACHINE-ibm-linux-$LIBC-	;;-    sh64*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    sh*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    sparc:Linux:*:* | sparc64:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    tile*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    vax:Linux:*:*)-	GUESS=$UNAME_MACHINE-dec-linux-$LIBC-	;;-    x86_64:Linux:*:*)-	set_cc_for_build-	LIBCABI=$LIBC-	if test "$CC_FOR_BUILD" != no_compiler_found; then-	    if (echo '#ifdef __ILP32__'; echo IS_X32; echo '#endif') | \-		(CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \-		grep IS_X32 >/dev/null-	    then-		LIBCABI=${LIBC}x32-	    fi-	fi-	GUESS=$UNAME_MACHINE-pc-linux-$LIBCABI-	;;-    xtensa*:Linux:*:*)-	GUESS=$UNAME_MACHINE-unknown-linux-$LIBC-	;;-    i*86:DYNIX/ptx:4*:*)-	# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.-	# earlier versions are messed up and put the nodename in both-	# sysname and nodename.-	GUESS=i386-sequent-sysv4-	;;-    i*86:UNIX_SV:4.2MP:2.*)-	# Unixware is an offshoot of SVR4, but it has its own version-	# number series starting with 2...-	# I am not positive that other SVR4 systems won't match this,-	# I just have to hope.  -- rms.-	# Use sysv4.2uw... so that sysv4* matches it.-	GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION-	;;-    i*86:OS/2:*:*)-	# If we were able to find `uname', then EMX Unix compatibility-	# is probably installed.-	GUESS=$UNAME_MACHINE-pc-os2-emx-	;;-    i*86:XTS-300:*:STOP)-	GUESS=$UNAME_MACHINE-unknown-stop-	;;-    i*86:atheos:*:*)-	GUESS=$UNAME_MACHINE-unknown-atheos-	;;-    i*86:syllable:*:*)-	GUESS=$UNAME_MACHINE-pc-syllable-	;;-    i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*)-	GUESS=i386-unknown-lynxos$UNAME_RELEASE-	;;-    i*86:*DOS:*:*)-	GUESS=$UNAME_MACHINE-pc-msdosdjgpp-	;;-    i*86:*:4.*:*)-	UNAME_REL=`echo "$UNAME_RELEASE" | sed 's/\/MP$//'`-	if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then-		GUESS=$UNAME_MACHINE-univel-sysv$UNAME_REL-	else-		GUESS=$UNAME_MACHINE-pc-sysv$UNAME_REL-	fi-	;;-    i*86:*:5:[678]*)-	# UnixWare 7.x, OpenUNIX and OpenServer 6.-	case `/bin/uname -X | grep "^Machine"` in-	    *486*)	     UNAME_MACHINE=i486 ;;-	    *Pentium)	     UNAME_MACHINE=i586 ;;-	    *Pent*|*Celeron) UNAME_MACHINE=i686 ;;-	esac-	GUESS=$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}-	;;-    i*86:*:3.2:*)-	if test -f /usr/options/cb.name; then-		UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`-		GUESS=$UNAME_MACHINE-pc-isc$UNAME_REL-	elif /bin/uname -X 2>/dev/null >/dev/null ; then-		UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')`-		(/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486-		(/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \-			&& UNAME_MACHINE=i586-		(/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \-			&& UNAME_MACHINE=i686-		(/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \-			&& UNAME_MACHINE=i686-		GUESS=$UNAME_MACHINE-pc-sco$UNAME_REL-	else-		GUESS=$UNAME_MACHINE-pc-sysv32-	fi-	;;-    pc:*:*:*)-	# Left here for compatibility:-	# uname -m prints for DJGPP always 'pc', but it prints nothing about-	# the processor, so we play safe by assuming i586.-	# Note: whatever this is, it MUST be the same as what config.sub-	# prints for the "djgpp" host, or else GDB configure will decide that-	# this is a cross-build.-	GUESS=i586-pc-msdosdjgpp-	;;-    Intel:Mach:3*:*)-	GUESS=i386-pc-mach3-	;;-    paragon:*:*:*)-	GUESS=i860-intel-osf1-	;;-    i860:*:4.*:*) # i860-SVR4-	if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then-	  GUESS=i860-stardent-sysv$UNAME_RELEASE    # Stardent Vistra i860-SVR4-	else # Add other i860-SVR4 vendors below as they are discovered.-	  GUESS=i860-unknown-sysv$UNAME_RELEASE     # Unknown i860-SVR4-	fi-	;;-    mini*:CTIX:SYS*5:*)-	# "miniframe"-	GUESS=m68010-convergent-sysv-	;;-    mc68k:UNIX:SYSTEM5:3.51m)-	GUESS=m68k-convergent-sysv-	;;-    M680?0:D-NIX:5.3:*)-	GUESS=m68k-diab-dnix-	;;-    M68*:*:R3V[5678]*:*)-	test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;-    3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)-	OS_REL=''-	test -r /etc/.relid \-	&& OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`-	/bin/uname -p 2>/dev/null | grep 86 >/dev/null \-	  && { echo i486-ncr-sysv4.3"$OS_REL"; exit; }-	/bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \-	  && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;;-    3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)-	/bin/uname -p 2>/dev/null | grep 86 >/dev/null \-	  && { echo i486-ncr-sysv4; exit; } ;;-    NCR*:*:4.2:* | MPRAS*:*:4.2:*)-	OS_REL='.3'-	test -r /etc/.relid \-	    && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`-	/bin/uname -p 2>/dev/null | grep 86 >/dev/null \-	    && { echo i486-ncr-sysv4.3"$OS_REL"; exit; }-	/bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \-	    && { echo i586-ncr-sysv4.3"$OS_REL"; exit; }-	/bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \-	    && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;;-    m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)-	GUESS=m68k-unknown-lynxos$UNAME_RELEASE-	;;-    mc68030:UNIX_System_V:4.*:*)-	GUESS=m68k-atari-sysv4-	;;-    TSUNAMI:LynxOS:2.*:*)-	GUESS=sparc-unknown-lynxos$UNAME_RELEASE-	;;-    rs6000:LynxOS:2.*:*)-	GUESS=rs6000-unknown-lynxos$UNAME_RELEASE-	;;-    PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*)-	GUESS=powerpc-unknown-lynxos$UNAME_RELEASE-	;;-    SM[BE]S:UNIX_SV:*:*)-	GUESS=mips-dde-sysv$UNAME_RELEASE-	;;-    RM*:ReliantUNIX-*:*:*)-	GUESS=mips-sni-sysv4-	;;-    RM*:SINIX-*:*:*)-	GUESS=mips-sni-sysv4-	;;-    *:SINIX-*:*:*)-	if uname -p 2>/dev/null >/dev/null ; then-		UNAME_MACHINE=`(uname -p) 2>/dev/null`-		GUESS=$UNAME_MACHINE-sni-sysv4-	else-		GUESS=ns32k-sni-sysv-	fi-	;;-    PENTIUM:*:4.0*:*)	# Unisys `ClearPath HMP IX 4000' SVR4/MP effort-			# says <Richard.M.Bartel@ccMail.Census.GOV>-	GUESS=i586-unisys-sysv4-	;;-    *:UNIX_System_V:4*:FTX*)-	# From Gerald Hewes <hewes@openmarket.com>.-	# How about differentiating between stratus architectures? -djm-	GUESS=hppa1.1-stratus-sysv4-	;;-    *:*:*:FTX*)-	# From seanf@swdc.stratus.com.-	GUESS=i860-stratus-sysv4-	;;-    i*86:VOS:*:*)-	# From Paul.Green@stratus.com.-	GUESS=$UNAME_MACHINE-stratus-vos-	;;-    *:VOS:*:*)-	# From Paul.Green@stratus.com.-	GUESS=hppa1.1-stratus-vos-	;;-    mc68*:A/UX:*:*)-	GUESS=m68k-apple-aux$UNAME_RELEASE-	;;-    news*:NEWS-OS:6*:*)-	GUESS=mips-sony-newsos6-	;;-    R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)-	if test -d /usr/nec; then-		GUESS=mips-nec-sysv$UNAME_RELEASE-	else-		GUESS=mips-unknown-sysv$UNAME_RELEASE-	fi-	;;-    BeBox:BeOS:*:*)	# BeOS running on hardware made by Be, PPC only.-	GUESS=powerpc-be-beos-	;;-    BeMac:BeOS:*:*)	# BeOS running on Mac or Mac clone, PPC only.-	GUESS=powerpc-apple-beos-	;;-    BePC:BeOS:*:*)	# BeOS running on Intel PC compatible.-	GUESS=i586-pc-beos-	;;-    BePC:Haiku:*:*)	# Haiku running on Intel PC compatible.-	GUESS=i586-pc-haiku-	;;-    x86_64:Haiku:*:*)-	GUESS=x86_64-unknown-haiku-	;;-    SX-4:SUPER-UX:*:*)-	GUESS=sx4-nec-superux$UNAME_RELEASE-	;;-    SX-5:SUPER-UX:*:*)-	GUESS=sx5-nec-superux$UNAME_RELEASE-	;;-    SX-6:SUPER-UX:*:*)-	GUESS=sx6-nec-superux$UNAME_RELEASE-	;;-    SX-7:SUPER-UX:*:*)-	GUESS=sx7-nec-superux$UNAME_RELEASE-	;;-    SX-8:SUPER-UX:*:*)-	GUESS=sx8-nec-superux$UNAME_RELEASE-	;;-    SX-8R:SUPER-UX:*:*)-	GUESS=sx8r-nec-superux$UNAME_RELEASE-	;;-    SX-ACE:SUPER-UX:*:*)-	GUESS=sxace-nec-superux$UNAME_RELEASE-	;;-    Power*:Rhapsody:*:*)-	GUESS=powerpc-apple-rhapsody$UNAME_RELEASE-	;;-    *:Rhapsody:*:*)-	GUESS=$UNAME_MACHINE-apple-rhapsody$UNAME_RELEASE-	;;-    arm64:Darwin:*:*)-	GUESS=aarch64-apple-darwin$UNAME_RELEASE-	;;-    *:Darwin:*:*)-	UNAME_PROCESSOR=`uname -p`-	case $UNAME_PROCESSOR in-	    unknown) UNAME_PROCESSOR=powerpc ;;-	esac-	if command -v xcode-select > /dev/null 2> /dev/null && \-		! xcode-select --print-path > /dev/null 2> /dev/null ; then-	    # Avoid executing cc if there is no toolchain installed as-	    # cc will be a stub that puts up a graphical alert-	    # prompting the user to install developer tools.-	    CC_FOR_BUILD=no_compiler_found-	else-	    set_cc_for_build-	fi-	if test "$CC_FOR_BUILD" != no_compiler_found; then-	    if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \-		   (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \-		   grep IS_64BIT_ARCH >/dev/null-	    then-		case $UNAME_PROCESSOR in-		    i386) UNAME_PROCESSOR=x86_64 ;;-		    powerpc) UNAME_PROCESSOR=powerpc64 ;;-		esac-	    fi-	    # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc-	    if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \-		   (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \-		   grep IS_PPC >/dev/null-	    then-		UNAME_PROCESSOR=powerpc-	    fi-	elif test "$UNAME_PROCESSOR" = i386 ; then-	    # uname -m returns i386 or x86_64-	    UNAME_PROCESSOR=$UNAME_MACHINE-	fi-	GUESS=$UNAME_PROCESSOR-apple-darwin$UNAME_RELEASE-	;;-    *:procnto*:*:* | *:QNX:[0123456789]*:*)-	UNAME_PROCESSOR=`uname -p`-	if test "$UNAME_PROCESSOR" = x86; then-		UNAME_PROCESSOR=i386-		UNAME_MACHINE=pc-	fi-	GUESS=$UNAME_PROCESSOR-$UNAME_MACHINE-nto-qnx$UNAME_RELEASE-	;;-    *:QNX:*:4*)-	GUESS=i386-pc-qnx-	;;-    NEO-*:NONSTOP_KERNEL:*:*)-	GUESS=neo-tandem-nsk$UNAME_RELEASE-	;;-    NSE-*:NONSTOP_KERNEL:*:*)-	GUESS=nse-tandem-nsk$UNAME_RELEASE-	;;-    NSR-*:NONSTOP_KERNEL:*:*)-	GUESS=nsr-tandem-nsk$UNAME_RELEASE-	;;-    NSV-*:NONSTOP_KERNEL:*:*)-	GUESS=nsv-tandem-nsk$UNAME_RELEASE-	;;-    NSX-*:NONSTOP_KERNEL:*:*)-	GUESS=nsx-tandem-nsk$UNAME_RELEASE-	;;-    *:NonStop-UX:*:*)-	GUESS=mips-compaq-nonstopux-	;;-    BS2000:POSIX*:*:*)-	GUESS=bs2000-siemens-sysv-	;;-    DS/*:UNIX_System_V:*:*)-	GUESS=$UNAME_MACHINE-$UNAME_SYSTEM-$UNAME_RELEASE-	;;-    *:Plan9:*:*)-	# "uname -m" is not consistent, so use $cputype instead. 386-	# is converted to i386 for consistency with other x86-	# operating systems.-	if test "${cputype-}" = 386; then-	    UNAME_MACHINE=i386-	elif test "x${cputype-}" != x; then-	    UNAME_MACHINE=$cputype-	fi-	GUESS=$UNAME_MACHINE-unknown-plan9-	;;-    *:TOPS-10:*:*)-	GUESS=pdp10-unknown-tops10-	;;-    *:TENEX:*:*)-	GUESS=pdp10-unknown-tenex-	;;-    KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)-	GUESS=pdp10-dec-tops20-	;;-    XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)-	GUESS=pdp10-xkl-tops20-	;;-    *:TOPS-20:*:*)-	GUESS=pdp10-unknown-tops20-	;;-    *:ITS:*:*)-	GUESS=pdp10-unknown-its-	;;-    SEI:*:*:SEIUX)-	GUESS=mips-sei-seiux$UNAME_RELEASE-	;;-    *:DragonFly:*:*)-	DRAGONFLY_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'`-	GUESS=$UNAME_MACHINE-unknown-dragonfly$DRAGONFLY_REL-	;;-    *:*VMS:*:*)-	UNAME_MACHINE=`(uname -p) 2>/dev/null`-	case $UNAME_MACHINE in-	    A*) GUESS=alpha-dec-vms ;;-	    I*) GUESS=ia64-dec-vms ;;-	    V*) GUESS=vax-dec-vms ;;-	esac ;;-    *:XENIX:*:SysV)-	GUESS=i386-pc-xenix-	;;-    i*86:skyos:*:*)-	SKYOS_REL=`echo "$UNAME_RELEASE" | sed -e 's/ .*$//'`-	GUESS=$UNAME_MACHINE-pc-skyos$SKYOS_REL-	;;-    i*86:rdos:*:*)-	GUESS=$UNAME_MACHINE-pc-rdos-	;;-    i*86:Fiwix:*:*)-	GUESS=$UNAME_MACHINE-pc-fiwix-	;;-    *:AROS:*:*)-	GUESS=$UNAME_MACHINE-unknown-aros-	;;-    x86_64:VMkernel:*:*)-	GUESS=$UNAME_MACHINE-unknown-esx-	;;-    amd64:Isilon\ OneFS:*:*)-	GUESS=x86_64-unknown-onefs-	;;-    *:Unleashed:*:*)-	GUESS=$UNAME_MACHINE-unknown-unleashed$UNAME_RELEASE-	;;-esac--# Do we have a guess based on uname results?-if test "x$GUESS" != x; then-    echo "$GUESS"-    exit-fi--# No uname command or uname output not recognized.-set_cc_for_build-cat > "$dummy.c" <<EOF-#ifdef _SEQUENT_-#include <sys/types.h>-#include <sys/utsname.h>-#endif-#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__)-#if defined (vax) || defined (__vax) || defined (__vax__) || defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__)-#include <signal.h>-#if defined(_SIZE_T_) || defined(SIGLOST)-#include <sys/utsname.h>-#endif-#endif-#endif-main ()-{-#if defined (sony)-#if defined (MIPSEB)-  /* BFD wants "bsd" instead of "newsos".  Perhaps BFD should be changed,-     I don't know....  */-  printf ("mips-sony-bsd\n"); exit (0);-#else-#include <sys/param.h>-  printf ("m68k-sony-newsos%s\n",-#ifdef NEWSOS4-  "4"-#else-  ""-#endif-  ); exit (0);-#endif-#endif--#if defined (NeXT)-#if !defined (__ARCHITECTURE__)-#define __ARCHITECTURE__ "m68k"-#endif-  int version;-  version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;-  if (version < 4)-    printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);-  else-    printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);-  exit (0);-#endif--#if defined (MULTIMAX) || defined (n16)-#if defined (UMAXV)-  printf ("ns32k-encore-sysv\n"); exit (0);-#else-#if defined (CMU)-  printf ("ns32k-encore-mach\n"); exit (0);-#else-  printf ("ns32k-encore-bsd\n"); exit (0);-#endif-#endif-#endif--#if defined (__386BSD__)-  printf ("i386-pc-bsd\n"); exit (0);-#endif--#if defined (sequent)-#if defined (i386)-  printf ("i386-sequent-dynix\n"); exit (0);-#endif-#if defined (ns32000)-  printf ("ns32k-sequent-dynix\n"); exit (0);-#endif-#endif--#if defined (_SEQUENT_)-  struct utsname un;--  uname(&un);-  if (strncmp(un.version, "V2", 2) == 0) {-    printf ("i386-sequent-ptx2\n"); exit (0);-  }-  if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */-    printf ("i386-sequent-ptx1\n"); exit (0);-  }-  printf ("i386-sequent-ptx\n"); exit (0);-#endif--#if defined (vax)-#if !defined (ultrix)-#include <sys/param.h>-#if defined (BSD)-#if BSD == 43-  printf ("vax-dec-bsd4.3\n"); exit (0);-#else-#if BSD == 199006-  printf ("vax-dec-bsd4.3reno\n"); exit (0);-#else-  printf ("vax-dec-bsd\n"); exit (0);-#endif-#endif-#else-  printf ("vax-dec-bsd\n"); exit (0);-#endif-#else-#if defined(_SIZE_T_) || defined(SIGLOST)-  struct utsname un;-  uname (&un);-  printf ("vax-dec-ultrix%s\n", un.release); exit (0);-#else-  printf ("vax-dec-ultrix\n"); exit (0);-#endif-#endif-#endif-#if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__)-#if defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__)-#if defined(_SIZE_T_) || defined(SIGLOST)-  struct utsname *un;-  uname (&un);-  printf ("mips-dec-ultrix%s\n", un.release); exit (0);-#else-  printf ("mips-dec-ultrix\n"); exit (0);-#endif-#endif-#endif--#if defined (alliant) && defined (i860)-  printf ("i860-alliant-bsd\n"); exit (0);-#endif--  exit (1);-}-EOF--$CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null && SYSTEM_NAME=`"$dummy"` &&-	{ echo "$SYSTEM_NAME"; exit; }--# Apollos put the system type in the environment.-test -d /usr/apollo && { echo "$ISP-apollo-$SYSTYPE"; exit; }--echo "$0: unable to guess system type" >&2--case $UNAME_MACHINE:$UNAME_SYSTEM in-    mips:Linux | mips64:Linux)-	# If we got here on MIPS GNU/Linux, output extra information.-	cat >&2 <<EOF--NOTE: MIPS GNU/Linux systems require a C compiler to fully recognize-the system type. Please install a C compiler and try again.-EOF-	;;-esac--cat >&2 <<EOF--This script (version $timestamp), has failed to recognize the-operating system you are using. If your script is old, overwrite *all*-copies of config.guess and config.sub with the latest versions from:--  https://git.savannah.gnu.org/cgit/config.git/plain/config.guess-and-  https://git.savannah.gnu.org/cgit/config.git/plain/config.sub-EOF--our_year=`echo $timestamp | sed 's,-.*,,'`-thisyear=`date +%Y`-# shellcheck disable=SC2003-script_age=`expr "$thisyear" - "$our_year"`-if test "$script_age" -lt 3 ; then-   cat >&2 <<EOF--If $0 has already been updated, send the following data and any-information you think might be pertinent to config-patches@gnu.org to-provide the necessary information to handle your system.--config.guess timestamp = $timestamp--uname -m = `(uname -m) 2>/dev/null || echo unknown`-uname -r = `(uname -r) 2>/dev/null || echo unknown`-uname -s = `(uname -s) 2>/dev/null || echo unknown`-uname -v = `(uname -v) 2>/dev/null || echo unknown`--/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null`-/bin/uname -X     = `(/bin/uname -X) 2>/dev/null`--hostinfo               = `(hostinfo) 2>/dev/null`-/bin/universe          = `(/bin/universe) 2>/dev/null`-/usr/bin/arch -k       = `(/usr/bin/arch -k) 2>/dev/null`-/bin/arch              = `(/bin/arch) 2>/dev/null`-/usr/bin/oslevel       = `(/usr/bin/oslevel) 2>/dev/null`-/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null`--UNAME_MACHINE = "$UNAME_MACHINE"-UNAME_RELEASE = "$UNAME_RELEASE"-UNAME_SYSTEM  = "$UNAME_SYSTEM"-UNAME_VERSION = "$UNAME_VERSION"-EOF-fi--exit 1--# Local variables:-# eval: (add-hook 'before-save-hook 'time-stamp)-# time-stamp-start: "timestamp='"-# time-stamp-format: "%:y-%02m-%02d"-# time-stamp-end: "'"-# End:
− config.sub 
@@ -1,1890 +0,0 @@-#! /bin/sh-# Configuration validation subroutine script.-#   Copyright 1992-2022 Free Software Foundation, Inc.--# shellcheck disable=SC2006,SC2268 # see below for rationale--timestamp='2022-01-03'--# This file is free software; you can redistribute it and/or modify it-# under the terms of the GNU General Public License as published by-# the Free Software Foundation, either version 3 of the License, or-# (at your option) any later version.-#-# This program is distributed in the hope that it will be useful, but-# WITHOUT ANY WARRANTY; without even the implied warranty of-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU-# General Public License for more details.-#-# You should have received a copy of the GNU General Public License-# along with this program; if not, see <https://www.gnu.org/licenses/>.-#-# As a special exception to the GNU General Public License, if you-# distribute this file as part of a program that contains a-# configuration script generated by Autoconf, you may include it under-# the same distribution terms that you use for the rest of that-# program.  This Exception is an additional permission under section 7-# of the GNU General Public License, version 3 ("GPLv3").---# Please send patches to <config-patches@gnu.org>.-#-# Configuration subroutine to validate and canonicalize a configuration type.-# Supply the specified configuration type as an argument.-# If it is invalid, we print an error message on stderr and exit with code 1.-# Otherwise, we print the canonical config type on stdout and succeed.--# You can get the latest version of this script from:-# https://git.savannah.gnu.org/cgit/config.git/plain/config.sub--# This file is supposed to be the same for all GNU packages-# and recognize all the CPU types, system types and aliases-# that are meaningful with *any* GNU software.-# Each package is responsible for reporting which valid configurations-# it does not support.  The user should be able to distinguish-# a failure to support a valid configuration from a meaningless-# configuration.--# The goal of this file is to map all the various variations of a given-# machine specification into a single specification in the form:-#	CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM-# or in some cases, the newer four-part form:-#	CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM-# It is wrong to echo any other type of specification.--# The "shellcheck disable" line above the timestamp inhibits complaints-# about features and limitations of the classic Bourne shell that were-# superseded or lifted in POSIX.  However, this script identifies a wide-# variety of pre-POSIX systems that do not have POSIX shells at all, and-# even some reasonably current systems (Solaris 10 as case-in-point) still-# have a pre-POSIX /bin/sh.--me=`echo "$0" | sed -e 's,.*/,,'`--usage="\-Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS--Canonicalize a configuration name.--Options:-  -h, --help         print this help, then exit-  -t, --time-stamp   print date of last modification, then exit-  -v, --version      print version number, then exit--Report bugs and patches to <config-patches@gnu.org>."--version="\-GNU config.sub ($timestamp)--Copyright 1992-2022 Free Software Foundation, Inc.--This is free software; see the source for copying conditions.  There is NO-warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."--help="-Try \`$me --help' for more information."--# Parse command line-while test $# -gt 0 ; do-  case $1 in-    --time-stamp | --time* | -t )-       echo "$timestamp" ; exit ;;-    --version | -v )-       echo "$version" ; exit ;;-    --help | --h* | -h )-       echo "$usage"; exit ;;-    -- )     # Stop option processing-       shift; break ;;-    - )	# Use stdin as input.-       break ;;-    -* )-       echo "$me: invalid option $1$help" >&2-       exit 1 ;;--    *local*)-       # First pass through any local machine types.-       echo "$1"-       exit ;;--    * )-       break ;;-  esac-done--case $# in- 0) echo "$me: missing argument$help" >&2-    exit 1;;- 1) ;;- *) echo "$me: too many arguments$help" >&2-    exit 1;;-esac--# Split fields of configuration type-# shellcheck disable=SC2162-saved_IFS=$IFS-IFS="-" read field1 field2 field3 field4 <<EOF-$1-EOF-IFS=$saved_IFS--# Separate into logical components for further validation-case $1 in-	*-*-*-*-*)-		echo Invalid configuration \`"$1"\': more than four components >&2-		exit 1-		;;-	*-*-*-*)-		basic_machine=$field1-$field2-		basic_os=$field3-$field4-		;;-	*-*-*)-		# Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two-		# parts-		maybe_os=$field2-$field3-		case $maybe_os in-			nto-qnx* | linux-* | uclinux-uclibc* \-			| uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \-			| netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \-			| storm-chaos* | os2-emx* | rtmk-nova*)-				basic_machine=$field1-				basic_os=$maybe_os-				;;-			android-linux)-				basic_machine=$field1-unknown-				basic_os=linux-android-				;;-			*)-				basic_machine=$field1-$field2-				basic_os=$field3-				;;-		esac-		;;-	*-*)-		# A lone config we happen to match not fitting any pattern-		case $field1-$field2 in-			decstation-3100)-				basic_machine=mips-dec-				basic_os=-				;;-			*-*)-				# Second component is usually, but not always the OS-				case $field2 in-					# Prevent following clause from handling this valid os-					sun*os*)-						basic_machine=$field1-						basic_os=$field2-						;;-					zephyr*)-						basic_machine=$field1-unknown-						basic_os=$field2-						;;-					# Manufacturers-					dec* | mips* | sequent* | encore* | pc533* | sgi* | sony* \-					| att* | 7300* | 3300* | delta* | motorola* | sun[234]* \-					| unicom* | ibm* | next | hp | isi* | apollo | altos* \-					| convergent* | ncr* | news | 32* | 3600* | 3100* \-					| hitachi* | c[123]* | convex* | sun | crds | omron* | dg \-					| ultra | tti* | harris | dolphin | highlevel | gould \-					| cbm | ns | masscomp | apple | axis | knuth | cray \-					| microblaze* | sim | cisco \-					| oki | wec | wrs | winbond)-						basic_machine=$field1-$field2-						basic_os=-						;;-					*)-						basic_machine=$field1-						basic_os=$field2-						;;-				esac-			;;-		esac-		;;-	*)-		# Convert single-component short-hands not valid as part of-		# multi-component configurations.-		case $field1 in-			386bsd)-				basic_machine=i386-pc-				basic_os=bsd-				;;-			a29khif)-				basic_machine=a29k-amd-				basic_os=udi-				;;-			adobe68k)-				basic_machine=m68010-adobe-				basic_os=scout-				;;-			alliant)-				basic_machine=fx80-alliant-				basic_os=-				;;-			altos | altos3068)-				basic_machine=m68k-altos-				basic_os=-				;;-			am29k)-				basic_machine=a29k-none-				basic_os=bsd-				;;-			amdahl)-				basic_machine=580-amdahl-				basic_os=sysv-				;;-			amiga)-				basic_machine=m68k-unknown-				basic_os=-				;;-			amigaos | amigados)-				basic_machine=m68k-unknown-				basic_os=amigaos-				;;-			amigaunix | amix)-				basic_machine=m68k-unknown-				basic_os=sysv4-				;;-			apollo68)-				basic_machine=m68k-apollo-				basic_os=sysv-				;;-			apollo68bsd)-				basic_machine=m68k-apollo-				basic_os=bsd-				;;-			aros)-				basic_machine=i386-pc-				basic_os=aros-				;;-			aux)-				basic_machine=m68k-apple-				basic_os=aux-				;;-			balance)-				basic_machine=ns32k-sequent-				basic_os=dynix-				;;-			blackfin)-				basic_machine=bfin-unknown-				basic_os=linux-				;;-			cegcc)-				basic_machine=arm-unknown-				basic_os=cegcc-				;;-			convex-c1)-				basic_machine=c1-convex-				basic_os=bsd-				;;-			convex-c2)-				basic_machine=c2-convex-				basic_os=bsd-				;;-			convex-c32)-				basic_machine=c32-convex-				basic_os=bsd-				;;-			convex-c34)-				basic_machine=c34-convex-				basic_os=bsd-				;;-			convex-c38)-				basic_machine=c38-convex-				basic_os=bsd-				;;-			cray)-				basic_machine=j90-cray-				basic_os=unicos-				;;-			crds | unos)-				basic_machine=m68k-crds-				basic_os=-				;;-			da30)-				basic_machine=m68k-da30-				basic_os=-				;;-			decstation | pmax | pmin | dec3100 | decstatn)-				basic_machine=mips-dec-				basic_os=-				;;-			delta88)-				basic_machine=m88k-motorola-				basic_os=sysv3-				;;-			dicos)-				basic_machine=i686-pc-				basic_os=dicos-				;;-			djgpp)-				basic_machine=i586-pc-				basic_os=msdosdjgpp-				;;-			ebmon29k)-				basic_machine=a29k-amd-				basic_os=ebmon-				;;-			es1800 | OSE68k | ose68k | ose | OSE)-				basic_machine=m68k-ericsson-				basic_os=ose-				;;-			gmicro)-				basic_machine=tron-gmicro-				basic_os=sysv-				;;-			go32)-				basic_machine=i386-pc-				basic_os=go32-				;;-			h8300hms)-				basic_machine=h8300-hitachi-				basic_os=hms-				;;-			h8300xray)-				basic_machine=h8300-hitachi-				basic_os=xray-				;;-			h8500hms)-				basic_machine=h8500-hitachi-				basic_os=hms-				;;-			harris)-				basic_machine=m88k-harris-				basic_os=sysv3-				;;-			hp300 | hp300hpux)-				basic_machine=m68k-hp-				basic_os=hpux-				;;-			hp300bsd)-				basic_machine=m68k-hp-				basic_os=bsd-				;;-			hppaosf)-				basic_machine=hppa1.1-hp-				basic_os=osf-				;;-			hppro)-				basic_machine=hppa1.1-hp-				basic_os=proelf-				;;-			i386mach)-				basic_machine=i386-mach-				basic_os=mach-				;;-			isi68 | isi)-				basic_machine=m68k-isi-				basic_os=sysv-				;;-			m68knommu)-				basic_machine=m68k-unknown-				basic_os=linux-				;;-			magnum | m3230)-				basic_machine=mips-mips-				basic_os=sysv-				;;-			merlin)-				basic_machine=ns32k-utek-				basic_os=sysv-				;;-			mingw64)-				basic_machine=x86_64-pc-				basic_os=mingw64-				;;-			mingw32)-				basic_machine=i686-pc-				basic_os=mingw32-				;;-			mingw32ce)-				basic_machine=arm-unknown-				basic_os=mingw32ce-				;;-			monitor)-				basic_machine=m68k-rom68k-				basic_os=coff-				;;-			morphos)-				basic_machine=powerpc-unknown-				basic_os=morphos-				;;-			moxiebox)-				basic_machine=moxie-unknown-				basic_os=moxiebox-				;;-			msdos)-				basic_machine=i386-pc-				basic_os=msdos-				;;-			msys)-				basic_machine=i686-pc-				basic_os=msys-				;;-			mvs)-				basic_machine=i370-ibm-				basic_os=mvs-				;;-			nacl)-				basic_machine=le32-unknown-				basic_os=nacl-				;;-			ncr3000)-				basic_machine=i486-ncr-				basic_os=sysv4-				;;-			netbsd386)-				basic_machine=i386-pc-				basic_os=netbsd-				;;-			netwinder)-				basic_machine=armv4l-rebel-				basic_os=linux-				;;-			news | news700 | news800 | news900)-				basic_machine=m68k-sony-				basic_os=newsos-				;;-			news1000)-				basic_machine=m68030-sony-				basic_os=newsos-				;;-			necv70)-				basic_machine=v70-nec-				basic_os=sysv-				;;-			nh3000)-				basic_machine=m68k-harris-				basic_os=cxux-				;;-			nh[45]000)-				basic_machine=m88k-harris-				basic_os=cxux-				;;-			nindy960)-				basic_machine=i960-intel-				basic_os=nindy-				;;-			mon960)-				basic_machine=i960-intel-				basic_os=mon960-				;;-			nonstopux)-				basic_machine=mips-compaq-				basic_os=nonstopux-				;;-			os400)-				basic_machine=powerpc-ibm-				basic_os=os400-				;;-			OSE68000 | ose68000)-				basic_machine=m68000-ericsson-				basic_os=ose-				;;-			os68k)-				basic_machine=m68k-none-				basic_os=os68k-				;;-			paragon)-				basic_machine=i860-intel-				basic_os=osf-				;;-			parisc)-				basic_machine=hppa-unknown-				basic_os=linux-				;;-			psp)-				basic_machine=mipsallegrexel-sony-				basic_os=psp-				;;-			pw32)-				basic_machine=i586-unknown-				basic_os=pw32-				;;-			rdos | rdos64)-				basic_machine=x86_64-pc-				basic_os=rdos-				;;-			rdos32)-				basic_machine=i386-pc-				basic_os=rdos-				;;-			rom68k)-				basic_machine=m68k-rom68k-				basic_os=coff-				;;-			sa29200)-				basic_machine=a29k-amd-				basic_os=udi-				;;-			sei)-				basic_machine=mips-sei-				basic_os=seiux-				;;-			sequent)-				basic_machine=i386-sequent-				basic_os=-				;;-			sps7)-				basic_machine=m68k-bull-				basic_os=sysv2-				;;-			st2000)-				basic_machine=m68k-tandem-				basic_os=-				;;-			stratus)-				basic_machine=i860-stratus-				basic_os=sysv4-				;;-			sun2)-				basic_machine=m68000-sun-				basic_os=-				;;-			sun2os3)-				basic_machine=m68000-sun-				basic_os=sunos3-				;;-			sun2os4)-				basic_machine=m68000-sun-				basic_os=sunos4-				;;-			sun3)-				basic_machine=m68k-sun-				basic_os=-				;;-			sun3os3)-				basic_machine=m68k-sun-				basic_os=sunos3-				;;-			sun3os4)-				basic_machine=m68k-sun-				basic_os=sunos4-				;;-			sun4)-				basic_machine=sparc-sun-				basic_os=-				;;-			sun4os3)-				basic_machine=sparc-sun-				basic_os=sunos3-				;;-			sun4os4)-				basic_machine=sparc-sun-				basic_os=sunos4-				;;-			sun4sol2)-				basic_machine=sparc-sun-				basic_os=solaris2-				;;-			sun386 | sun386i | roadrunner)-				basic_machine=i386-sun-				basic_os=-				;;-			sv1)-				basic_machine=sv1-cray-				basic_os=unicos-				;;-			symmetry)-				basic_machine=i386-sequent-				basic_os=dynix-				;;-			t3e)-				basic_machine=alphaev5-cray-				basic_os=unicos-				;;-			t90)-				basic_machine=t90-cray-				basic_os=unicos-				;;-			toad1)-				basic_machine=pdp10-xkl-				basic_os=tops20-				;;-			tpf)-				basic_machine=s390x-ibm-				basic_os=tpf-				;;-			udi29k)-				basic_machine=a29k-amd-				basic_os=udi-				;;-			ultra3)-				basic_machine=a29k-nyu-				basic_os=sym1-				;;-			v810 | necv810)-				basic_machine=v810-nec-				basic_os=none-				;;-			vaxv)-				basic_machine=vax-dec-				basic_os=sysv-				;;-			vms)-				basic_machine=vax-dec-				basic_os=vms-				;;-			vsta)-				basic_machine=i386-pc-				basic_os=vsta-				;;-			vxworks960)-				basic_machine=i960-wrs-				basic_os=vxworks-				;;-			vxworks68)-				basic_machine=m68k-wrs-				basic_os=vxworks-				;;-			vxworks29k)-				basic_machine=a29k-wrs-				basic_os=vxworks-				;;-			xbox)-				basic_machine=i686-pc-				basic_os=mingw32-				;;-			ymp)-				basic_machine=ymp-cray-				basic_os=unicos-				;;-			*)-				basic_machine=$1-				basic_os=-				;;-		esac-		;;-esac--# Decode 1-component or ad-hoc basic machines-case $basic_machine in-	# Here we handle the default manufacturer of certain CPU types.  It is in-	# some cases the only manufacturer, in others, it is the most popular.-	w89k)-		cpu=hppa1.1-		vendor=winbond-		;;-	op50n)-		cpu=hppa1.1-		vendor=oki-		;;-	op60c)-		cpu=hppa1.1-		vendor=oki-		;;-	ibm*)-		cpu=i370-		vendor=ibm-		;;-	orion105)-		cpu=clipper-		vendor=highlevel-		;;-	mac | mpw | mac-mpw)-		cpu=m68k-		vendor=apple-		;;-	pmac | pmac-mpw)-		cpu=powerpc-		vendor=apple-		;;--	# Recognize the various machine names and aliases which stand-	# for a CPU type and a company and sometimes even an OS.-	3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)-		cpu=m68000-		vendor=att-		;;-	3b*)-		cpu=we32k-		vendor=att-		;;-	bluegene*)-		cpu=powerpc-		vendor=ibm-		basic_os=cnk-		;;-	decsystem10* | dec10*)-		cpu=pdp10-		vendor=dec-		basic_os=tops10-		;;-	decsystem20* | dec20*)-		cpu=pdp10-		vendor=dec-		basic_os=tops20-		;;-	delta | 3300 | motorola-3300 | motorola-delta \-	      | 3300-motorola | delta-motorola)-		cpu=m68k-		vendor=motorola-		;;-	dpx2*)-		cpu=m68k-		vendor=bull-		basic_os=sysv3-		;;-	encore | umax | mmax)-		cpu=ns32k-		vendor=encore-		;;-	elxsi)-		cpu=elxsi-		vendor=elxsi-		basic_os=${basic_os:-bsd}-		;;-	fx2800)-		cpu=i860-		vendor=alliant-		;;-	genix)-		cpu=ns32k-		vendor=ns-		;;-	h3050r* | hiux*)-		cpu=hppa1.1-		vendor=hitachi-		basic_os=hiuxwe2-		;;-	hp3k9[0-9][0-9] | hp9[0-9][0-9])-		cpu=hppa1.0-		vendor=hp-		;;-	hp9k2[0-9][0-9] | hp9k31[0-9])-		cpu=m68000-		vendor=hp-		;;-	hp9k3[2-9][0-9])-		cpu=m68k-		vendor=hp-		;;-	hp9k6[0-9][0-9] | hp6[0-9][0-9])-		cpu=hppa1.0-		vendor=hp-		;;-	hp9k7[0-79][0-9] | hp7[0-79][0-9])-		cpu=hppa1.1-		vendor=hp-		;;-	hp9k78[0-9] | hp78[0-9])-		# FIXME: really hppa2.0-hp-		cpu=hppa1.1-		vendor=hp-		;;-	hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)-		# FIXME: really hppa2.0-hp-		cpu=hppa1.1-		vendor=hp-		;;-	hp9k8[0-9][13679] | hp8[0-9][13679])-		cpu=hppa1.1-		vendor=hp-		;;-	hp9k8[0-9][0-9] | hp8[0-9][0-9])-		cpu=hppa1.0-		vendor=hp-		;;-	i*86v32)-		cpu=`echo "$1" | sed -e 's/86.*/86/'`-		vendor=pc-		basic_os=sysv32-		;;-	i*86v4*)-		cpu=`echo "$1" | sed -e 's/86.*/86/'`-		vendor=pc-		basic_os=sysv4-		;;-	i*86v)-		cpu=`echo "$1" | sed -e 's/86.*/86/'`-		vendor=pc-		basic_os=sysv-		;;-	i*86sol2)-		cpu=`echo "$1" | sed -e 's/86.*/86/'`-		vendor=pc-		basic_os=solaris2-		;;-	j90 | j90-cray)-		cpu=j90-		vendor=cray-		basic_os=${basic_os:-unicos}-		;;-	iris | iris4d)-		cpu=mips-		vendor=sgi-		case $basic_os in-		    irix*)-			;;-		    *)-			basic_os=irix4-			;;-		esac-		;;-	miniframe)-		cpu=m68000-		vendor=convergent-		;;-	*mint | mint[0-9]* | *MiNT | *MiNT[0-9]*)-		cpu=m68k-		vendor=atari-		basic_os=mint-		;;-	news-3600 | risc-news)-		cpu=mips-		vendor=sony-		basic_os=newsos-		;;-	next | m*-next)-		cpu=m68k-		vendor=next-		case $basic_os in-		    openstep*)-		        ;;-		    nextstep*)-			;;-		    ns2*)-		      basic_os=nextstep2-			;;-		    *)-		      basic_os=nextstep3-			;;-		esac-		;;-	np1)-		cpu=np1-		vendor=gould-		;;-	op50n-* | op60c-*)-		cpu=hppa1.1-		vendor=oki-		basic_os=proelf-		;;-	pa-hitachi)-		cpu=hppa1.1-		vendor=hitachi-		basic_os=hiuxwe2-		;;-	pbd)-		cpu=sparc-		vendor=tti-		;;-	pbb)-		cpu=m68k-		vendor=tti-		;;-	pc532)-		cpu=ns32k-		vendor=pc532-		;;-	pn)-		cpu=pn-		vendor=gould-		;;-	power)-		cpu=power-		vendor=ibm-		;;-	ps2)-		cpu=i386-		vendor=ibm-		;;-	rm[46]00)-		cpu=mips-		vendor=siemens-		;;-	rtpc | rtpc-*)-		cpu=romp-		vendor=ibm-		;;-	sde)-		cpu=mipsisa32-		vendor=sde-		basic_os=${basic_os:-elf}-		;;-	simso-wrs)-		cpu=sparclite-		vendor=wrs-		basic_os=vxworks-		;;-	tower | tower-32)-		cpu=m68k-		vendor=ncr-		;;-	vpp*|vx|vx-*)-		cpu=f301-		vendor=fujitsu-		;;-	w65)-		cpu=w65-		vendor=wdc-		;;-	w89k-*)-		cpu=hppa1.1-		vendor=winbond-		basic_os=proelf-		;;-	none)-		cpu=none-		vendor=none-		;;-	leon|leon[3-9])-		cpu=sparc-		vendor=$basic_machine-		;;-	leon-*|leon[3-9]-*)-		cpu=sparc-		vendor=`echo "$basic_machine" | sed 's/-.*//'`-		;;--	*-*)-		# shellcheck disable=SC2162-		saved_IFS=$IFS-		IFS="-" read cpu vendor <<EOF-$basic_machine-EOF-		IFS=$saved_IFS-		;;-	# We use `pc' rather than `unknown'-	# because (1) that's what they normally are, and-	# (2) the word "unknown" tends to confuse beginning users.-	i*86 | x86_64)-		cpu=$basic_machine-		vendor=pc-		;;-	# These rules are duplicated from below for sake of the special case above;-	# i.e. things that normalized to x86 arches should also default to "pc"-	pc98)-		cpu=i386-		vendor=pc-		;;-	x64 | amd64)-		cpu=x86_64-		vendor=pc-		;;-	# Recognize the basic CPU types without company name.-	*)-		cpu=$basic_machine-		vendor=unknown-		;;-esac--unset -v basic_machine--# Decode basic machines in the full and proper CPU-Company form.-case $cpu-$vendor in-	# Here we handle the default manufacturer of certain CPU types in canonical form. It is in-	# some cases the only manufacturer, in others, it is the most popular.-	craynv-unknown)-		vendor=cray-		basic_os=${basic_os:-unicosmp}-		;;-	c90-unknown | c90-cray)-		vendor=cray-		basic_os=${Basic_os:-unicos}-		;;-	fx80-unknown)-		vendor=alliant-		;;-	romp-unknown)-		vendor=ibm-		;;-	mmix-unknown)-		vendor=knuth-		;;-	microblaze-unknown | microblazeel-unknown)-		vendor=xilinx-		;;-	rs6000-unknown)-		vendor=ibm-		;;-	vax-unknown)-		vendor=dec-		;;-	pdp11-unknown)-		vendor=dec-		;;-	we32k-unknown)-		vendor=att-		;;-	cydra-unknown)-		vendor=cydrome-		;;-	i370-ibm*)-		vendor=ibm-		;;-	orion-unknown)-		vendor=highlevel-		;;-	xps-unknown | xps100-unknown)-		cpu=xps100-		vendor=honeywell-		;;--	# Here we normalize CPU types with a missing or matching vendor-	armh-unknown | armh-alt)-		cpu=armv7l-		vendor=alt-		basic_os=${basic_os:-linux-gnueabihf}-		;;-	dpx20-unknown | dpx20-bull)-		cpu=rs6000-		vendor=bull-		basic_os=${basic_os:-bosx}-		;;--	# Here we normalize CPU types irrespective of the vendor-	amd64-*)-		cpu=x86_64-		;;-	blackfin-*)-		cpu=bfin-		basic_os=linux-		;;-	c54x-*)-		cpu=tic54x-		;;-	c55x-*)-		cpu=tic55x-		;;-	c6x-*)-		cpu=tic6x-		;;-	e500v[12]-*)-		cpu=powerpc-		basic_os=${basic_os}"spe"-		;;-	mips3*-*)-		cpu=mips64-		;;-	ms1-*)-		cpu=mt-		;;-	m68knommu-*)-		cpu=m68k-		basic_os=linux-		;;-	m9s12z-* | m68hcs12z-* | hcs12z-* | s12z-*)-		cpu=s12z-		;;-	openrisc-*)-		cpu=or32-		;;-	parisc-*)-		cpu=hppa-		basic_os=linux-		;;-	pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)-		cpu=i586-		;;-	pentiumpro-* | p6-* | 6x86-* | athlon-* | athalon_*-*)-		cpu=i686-		;;-	pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)-		cpu=i686-		;;-	pentium4-*)-		cpu=i786-		;;-	pc98-*)-		cpu=i386-		;;-	ppc-* | ppcbe-*)-		cpu=powerpc-		;;-	ppcle-* | powerpclittle-*)-		cpu=powerpcle-		;;-	ppc64-*)-		cpu=powerpc64-		;;-	ppc64le-* | powerpc64little-*)-		cpu=powerpc64le-		;;-	sb1-*)-		cpu=mipsisa64sb1-		;;-	sb1el-*)-		cpu=mipsisa64sb1el-		;;-	sh5e[lb]-*)-		cpu=`echo "$cpu" | sed 's/^\(sh.\)e\(.\)$/\1\2e/'`-		;;-	spur-*)-		cpu=spur-		;;-	strongarm-* | thumb-*)-		cpu=arm-		;;-	tx39-*)-		cpu=mipstx39-		;;-	tx39el-*)-		cpu=mipstx39el-		;;-	x64-*)-		cpu=x86_64-		;;-	xscale-* | xscalee[bl]-*)-		cpu=`echo "$cpu" | sed 's/^xscale/arm/'`-		;;-	arm64-* | aarch64le-*)-		cpu=aarch64-		;;--	# Recognize the canonical CPU Types that limit and/or modify the-	# company names they are paired with.-	cr16-*)-		basic_os=${basic_os:-elf}-		;;-	crisv32-* | etraxfs*-*)-		cpu=crisv32-		vendor=axis-		;;-	cris-* | etrax*-*)-		cpu=cris-		vendor=axis-		;;-	crx-*)-		basic_os=${basic_os:-elf}-		;;-	neo-tandem)-		cpu=neo-		vendor=tandem-		;;-	nse-tandem)-		cpu=nse-		vendor=tandem-		;;-	nsr-tandem)-		cpu=nsr-		vendor=tandem-		;;-	nsv-tandem)-		cpu=nsv-		vendor=tandem-		;;-	nsx-tandem)-		cpu=nsx-		vendor=tandem-		;;-	mipsallegrexel-sony)-		cpu=mipsallegrexel-		vendor=sony-		;;-	tile*-*)-		basic_os=${basic_os:-linux-gnu}-		;;--	*)-		# Recognize the canonical CPU types that are allowed with any-		# company name.-		case $cpu in-			1750a | 580 \-			| a29k \-			| aarch64 | aarch64_be \-			| abacus \-			| alpha | alphaev[4-8] | alphaev56 | alphaev6[78] \-			| alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] \-			| alphapca5[67] | alpha64pca5[67] \-			| am33_2.0 \-			| amdgcn \-			| arc | arceb | arc32 | arc64 \-			| arm | arm[lb]e | arme[lb] | armv* \-			| avr | avr32 \-			| asmjs \-			| ba \-			| be32 | be64 \-			| bfin | bpf | bs2000 \-			| c[123]* | c30 | [cjt]90 | c4x \-			| c8051 | clipper | craynv | csky | cydra \-			| d10v | d30v | dlx | dsp16xx \-			| e2k | elxsi | epiphany \-			| f30[01] | f700 | fido | fr30 | frv | ft32 | fx80 \-			| h8300 | h8500 \-			| hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \-			| hexagon \-			| i370 | i*86 | i860 | i960 | ia16 | ia64 \-			| ip2k | iq2000 \-			| k1om \-			| le32 | le64 \-			| lm32 \-			| loongarch32 | loongarch64 | loongarchx32 \-			| m32c | m32r | m32rle \-			| m5200 | m68000 | m680[012346]0 | m68360 | m683?2 | m68k \-			| m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x \-			| m88110 | m88k | maxq | mb | mcore | mep | metag \-			| microblaze | microblazeel \-			| mips | mipsbe | mipseb | mipsel | mipsle \-			| mips16 \-			| mips64 | mips64eb | mips64el \-			| mips64octeon | mips64octeonel \-			| mips64orion | mips64orionel \-			| mips64r5900 | mips64r5900el \-			| mips64vr | mips64vrel \-			| mips64vr4100 | mips64vr4100el \-			| mips64vr4300 | mips64vr4300el \-			| mips64vr5000 | mips64vr5000el \-			| mips64vr5900 | mips64vr5900el \-			| mipsisa32 | mipsisa32el \-			| mipsisa32r2 | mipsisa32r2el \-			| mipsisa32r3 | mipsisa32r3el \-			| mipsisa32r5 | mipsisa32r5el \-			| mipsisa32r6 | mipsisa32r6el \-			| mipsisa64 | mipsisa64el \-			| mipsisa64r2 | mipsisa64r2el \-			| mipsisa64r3 | mipsisa64r3el \-			| mipsisa64r5 | mipsisa64r5el \-			| mipsisa64r6 | mipsisa64r6el \-			| mipsisa64sb1 | mipsisa64sb1el \-			| mipsisa64sr71k | mipsisa64sr71kel \-			| mipsr5900 | mipsr5900el \-			| mipstx39 | mipstx39el \-			| mmix \-			| mn10200 | mn10300 \-			| moxie \-			| mt \-			| msp430 \-			| nds32 | nds32le | nds32be \-			| nfp \-			| nios | nios2 | nios2eb | nios2el \-			| none | np1 | ns16k | ns32k | nvptx \-			| open8 \-			| or1k* \-			| or32 \-			| orion \-			| picochip \-			| pdp10 | pdp11 | pj | pjl | pn | power \-			| powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \-			| pru \-			| pyramid \-			| riscv | riscv32 | riscv32be | riscv64 | riscv64be \-			| rl78 | romp | rs6000 | rx \-			| s390 | s390x \-			| score \-			| sh | shl \-			| sh[1234] | sh[24]a | sh[24]ae[lb] | sh[23]e | she[lb] | sh[lb]e \-			| sh[1234]e[lb] |  sh[12345][lb]e | sh[23]ele | sh64 | sh64le \-			| sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet \-			| sparclite \-			| sparcv8 | sparcv9 | sparcv9b | sparcv9v | sv1 | sx* \-			| spu \-			| tahoe \-			| thumbv7* \-			| tic30 | tic4x | tic54x | tic55x | tic6x | tic80 \-			| tron \-			| ubicom32 \-			| v70 | v850 | v850e | v850e1 | v850es | v850e2 | v850e2v3 \-			| vax \-			| visium \-			| w65 \-			| wasm32 | wasm64 \-			| we32k \-			| x86 | x86_64 | xc16x | xgate | xps100 \-			| xstormy16 | xtensa* \-			| ymp \-			| z8k | z80)-				;;--			*)-				echo Invalid configuration \`"$1"\': machine \`"$cpu-$vendor"\' not recognized 1>&2-				exit 1-				;;-		esac-		;;-esac--# Here we canonicalize certain aliases for manufacturers.-case $vendor in-	digital*)-		vendor=dec-		;;-	commodore*)-		vendor=cbm-		;;-	*)-		;;-esac--# Decode manufacturer-specific aliases for certain operating systems.--if test x$basic_os != x-then--# First recognize some ad-hoc cases, or perhaps split kernel-os, or else just-# set os.-case $basic_os in-	gnu/linux*)-		kernel=linux-		os=`echo "$basic_os" | sed -e 's|gnu/linux|gnu|'`-		;;-	os2-emx)-		kernel=os2-		os=`echo "$basic_os" | sed -e 's|os2-emx|emx|'`-		;;-	nto-qnx*)-		kernel=nto-		os=`echo "$basic_os" | sed -e 's|nto-qnx|qnx|'`-		;;-	*-*)-		# shellcheck disable=SC2162-		saved_IFS=$IFS-		IFS="-" read kernel os <<EOF-$basic_os-EOF-		IFS=$saved_IFS-		;;-	# Default OS when just kernel was specified-	nto*)-		kernel=nto-		os=`echo "$basic_os" | sed -e 's|nto|qnx|'`-		;;-	linux*)-		kernel=linux-		os=`echo "$basic_os" | sed -e 's|linux|gnu|'`-		;;-	*)-		kernel=-		os=$basic_os-		;;-esac--# Now, normalize the OS (knowing we just have one component, it's not a kernel,-# etc.)-case $os in-	# First match some system type aliases that might get confused-	# with valid system types.-	# solaris* is a basic system type, with this one exception.-	auroraux)-		os=auroraux-		;;-	bluegene*)-		os=cnk-		;;-	solaris1 | solaris1.*)-		os=`echo "$os" | sed -e 's|solaris1|sunos4|'`-		;;-	solaris)-		os=solaris2-		;;-	unixware*)-		os=sysv4.2uw-		;;-	# es1800 is here to avoid being matched by es* (a different OS)-	es1800*)-		os=ose-		;;-	# Some version numbers need modification-	chorusos*)-		os=chorusos-		;;-	isc)-		os=isc2.2-		;;-	sco6)-		os=sco5v6-		;;-	sco5)-		os=sco3.2v5-		;;-	sco4)-		os=sco3.2v4-		;;-	sco3.2.[4-9]*)-		os=`echo "$os" | sed -e 's/sco3.2./sco3.2v/'`-		;;-	sco*v* | scout)-		# Don't match below-		;;-	sco*)-		os=sco3.2v2-		;;-	psos*)-		os=psos-		;;-	qnx*)-		os=qnx-		;;-	hiux*)-		os=hiuxwe2-		;;-	lynx*178)-		os=lynxos178-		;;-	lynx*5)-		os=lynxos5-		;;-	lynxos*)-		# don't get caught up in next wildcard-		;;-	lynx*)-		os=lynxos-		;;-	mac[0-9]*)-		os=`echo "$os" | sed -e 's|mac|macos|'`-		;;-	opened*)-		os=openedition-		;;-	os400*)-		os=os400-		;;-	sunos5*)-		os=`echo "$os" | sed -e 's|sunos5|solaris2|'`-		;;-	sunos6*)-		os=`echo "$os" | sed -e 's|sunos6|solaris3|'`-		;;-	wince*)-		os=wince-		;;-	utek*)-		os=bsd-		;;-	dynix*)-		os=bsd-		;;-	acis*)-		os=aos-		;;-	atheos*)-		os=atheos-		;;-	syllable*)-		os=syllable-		;;-	386bsd)-		os=bsd-		;;-	ctix* | uts*)-		os=sysv-		;;-	nova*)-		os=rtmk-nova-		;;-	ns2)-		os=nextstep2-		;;-	# Preserve the version number of sinix5.-	sinix5.*)-		os=`echo "$os" | sed -e 's|sinix|sysv|'`-		;;-	sinix*)-		os=sysv4-		;;-	tpf*)-		os=tpf-		;;-	triton*)-		os=sysv3-		;;-	oss*)-		os=sysv3-		;;-	svr4*)-		os=sysv4-		;;-	svr3)-		os=sysv3-		;;-	sysvr4)-		os=sysv4-		;;-	ose*)-		os=ose-		;;-	*mint | mint[0-9]* | *MiNT | MiNT[0-9]*)-		os=mint-		;;-	dicos*)-		os=dicos-		;;-	pikeos*)-		# Until real need of OS specific support for-		# particular features comes up, bare metal-		# configurations are quite functional.-		case $cpu in-		    arm*)-			os=eabi-			;;-		    *)-			os=elf-			;;-		esac-		;;-	*)-		# No normalization, but not necessarily accepted, that comes below.-		;;-esac--else--# Here we handle the default operating systems that come with various machines.-# The value should be what the vendor currently ships out the door with their-# machine or put another way, the most popular os provided with the machine.--# Note that if you're going to try to match "-MANUFACTURER" here (say,-# "-sun"), then you have to tell the case statement up towards the top-# that MANUFACTURER isn't an operating system.  Otherwise, code above-# will signal an error saying that MANUFACTURER isn't an operating-# system, and we'll never get to this point.--kernel=-case $cpu-$vendor in-	score-*)-		os=elf-		;;-	spu-*)-		os=elf-		;;-	*-acorn)-		os=riscix1.2-		;;-	arm*-rebel)-		kernel=linux-		os=gnu-		;;-	arm*-semi)-		os=aout-		;;-	c4x-* | tic4x-*)-		os=coff-		;;-	c8051-*)-		os=elf-		;;-	clipper-intergraph)-		os=clix-		;;-	hexagon-*)-		os=elf-		;;-	tic54x-*)-		os=coff-		;;-	tic55x-*)-		os=coff-		;;-	tic6x-*)-		os=coff-		;;-	# This must come before the *-dec entry.-	pdp10-*)-		os=tops20-		;;-	pdp11-*)-		os=none-		;;-	*-dec | vax-*)-		os=ultrix4.2-		;;-	m68*-apollo)-		os=domain-		;;-	i386-sun)-		os=sunos4.0.2-		;;-	m68000-sun)-		os=sunos3-		;;-	m68*-cisco)-		os=aout-		;;-	mep-*)-		os=elf-		;;-	mips*-cisco)-		os=elf-		;;-	mips*-*)-		os=elf-		;;-	or32-*)-		os=coff-		;;-	*-tti)	# must be before sparc entry or we get the wrong os.-		os=sysv3-		;;-	sparc-* | *-sun)-		os=sunos4.1.1-		;;-	pru-*)-		os=elf-		;;-	*-be)-		os=beos-		;;-	*-ibm)-		os=aix-		;;-	*-knuth)-		os=mmixware-		;;-	*-wec)-		os=proelf-		;;-	*-winbond)-		os=proelf-		;;-	*-oki)-		os=proelf-		;;-	*-hp)-		os=hpux-		;;-	*-hitachi)-		os=hiux-		;;-	i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)-		os=sysv-		;;-	*-cbm)-		os=amigaos-		;;-	*-dg)-		os=dgux-		;;-	*-dolphin)-		os=sysv3-		;;-	m68k-ccur)-		os=rtu-		;;-	m88k-omron*)-		os=luna-		;;-	*-next)-		os=nextstep-		;;-	*-sequent)-		os=ptx-		;;-	*-crds)-		os=unos-		;;-	*-ns)-		os=genix-		;;-	i370-*)-		os=mvs-		;;-	*-gould)-		os=sysv-		;;-	*-highlevel)-		os=bsd-		;;-	*-encore)-		os=bsd-		;;-	*-sgi)-		os=irix-		;;-	*-siemens)-		os=sysv4-		;;-	*-masscomp)-		os=rtu-		;;-	f30[01]-fujitsu | f700-fujitsu)-		os=uxpv-		;;-	*-rom68k)-		os=coff-		;;-	*-*bug)-		os=coff-		;;-	*-apple)-		os=macos-		;;-	*-atari*)-		os=mint-		;;-	*-wrs)-		os=vxworks-		;;-	*)-		os=none-		;;-esac--fi--# Now, validate our (potentially fixed-up) OS.-case $os in-	# Sometimes we do "kernel-libc", so those need to count as OSes.-	musl* | newlib* | relibc* | uclibc*)-		;;-	# Likewise for "kernel-abi"-	eabi* | gnueabi*)-		;;-	# VxWorks passes extra cpu info in the 4th filed.-	simlinux | simwindows | spe)-		;;-	# Now accept the basic system types.-	# The portable systems comes first.-	# Each alternative MUST end in a * to match a version number.-	gnu* | android* | bsd* | mach* | minix* | genix* | ultrix* | irix* \-	     | *vms* | esix* | aix* | cnk* | sunos | sunos[34]* \-	     | hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \-	     | sym* |  plan9* | psp* | sim* | xray* | os68k* | v88r* \-	     | hiux* | abug | nacl* | netware* | windows* \-	     | os9* | macos* | osx* | ios* \-	     | mpw* | magic* | mmixware* | mon960* | lnews* \-	     | amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \-	     | aos* | aros* | cloudabi* | sortix* | twizzler* \-	     | nindy* | vxsim* | vxworks* | ebmon* | hms* | mvs* \-	     | clix* | riscos* | uniplus* | iris* | isc* | rtu* | xenix* \-	     | mirbsd* | netbsd* | dicos* | openedition* | ose* \-	     | bitrig* | openbsd* | secbsd* | solidbsd* | libertybsd* | os108* \-	     | ekkobsd* | freebsd* | riscix* | lynxos* | os400* \-	     | bosx* | nextstep* | cxux* | aout* | elf* | oabi* \-	     | ptx* | coff* | ecoff* | winnt* | domain* | vsta* \-	     | udi* | lites* | ieee* | go32* | aux* | hcos* \-	     | chorusrdb* | cegcc* | glidix* | serenity* \-	     | cygwin* | msys* | pe* | moss* | proelf* | rtems* \-	     | midipix* | mingw32* | mingw64* | mint* \-	     | uxpv* | beos* | mpeix* | udk* | moxiebox* \-	     | interix* | uwin* | mks* | rhapsody* | darwin* \-	     | openstep* | oskit* | conix* | pw32* | nonstopux* \-	     | storm-chaos* | tops10* | tenex* | tops20* | its* \-	     | os2* | vos* | palmos* | uclinux* | nucleus* | morphos* \-	     | scout* | superux* | sysv* | rtmk* | tpf* | windiss* \-	     | powermax* | dnix* | nx6 | nx7 | sei* | dragonfly* \-	     | skyos* | haiku* | rdos* | toppers* | drops* | es* \-	     | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \-	     | midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \-	     | nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \-	     | fiwix* )-		;;-	# This one is extra strict with allowed versions-	sco3.2v2 | sco3.2v[4-9]* | sco5v6*)-		# Don't forget version if it is 3.2v4 or newer.-		;;-	none)-		;;-	*)-		echo Invalid configuration \`"$1"\': OS \`"$os"\' not recognized 1>&2-		exit 1-		;;-esac--# As a final step for OS-related things, validate the OS-kernel combination-# (given a valid OS), if there is a kernel.-case $kernel-$os in-	linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \-		   | linux-musl* | linux-relibc* | linux-uclibc* )-		;;-	uclinux-uclibc* )-		;;-	-dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* )-		# These are just libc implementations, not actual OSes, and thus-		# require a kernel.-		echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2-		exit 1-		;;-	kfreebsd*-gnu* | kopensolaris*-gnu*)-		;;-	vxworks-simlinux | vxworks-simwindows | vxworks-spe)-		;;-	nto-qnx*)-		;;-	os2-emx)-		;;-	*-eabi* | *-gnueabi*)-		;;-	-*)-		# Blank kernel with real OS is always fine.-		;;-	*-*)-		echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2-		exit 1-		;;-esac--# Here we handle the case where we know the os, and the CPU type, but not the-# manufacturer.  We pick the logical manufacturer.-case $vendor in-	unknown)-		case $cpu-$os in-			*-riscix*)-				vendor=acorn-				;;-			*-sunos*)-				vendor=sun-				;;-			*-cnk* | *-aix*)-				vendor=ibm-				;;-			*-beos*)-				vendor=be-				;;-			*-hpux*)-				vendor=hp-				;;-			*-mpeix*)-				vendor=hp-				;;-			*-hiux*)-				vendor=hitachi-				;;-			*-unos*)-				vendor=crds-				;;-			*-dgux*)-				vendor=dg-				;;-			*-luna*)-				vendor=omron-				;;-			*-genix*)-				vendor=ns-				;;-			*-clix*)-				vendor=intergraph-				;;-			*-mvs* | *-opened*)-				vendor=ibm-				;;-			*-os400*)-				vendor=ibm-				;;-			s390-* | s390x-*)-				vendor=ibm-				;;-			*-ptx*)-				vendor=sequent-				;;-			*-tpf*)-				vendor=ibm-				;;-			*-vxsim* | *-vxworks* | *-windiss*)-				vendor=wrs-				;;-			*-aux*)-				vendor=apple-				;;-			*-hms*)-				vendor=hitachi-				;;-			*-mpw* | *-macos*)-				vendor=apple-				;;-			*-*mint | *-mint[0-9]* | *-*MiNT | *-MiNT[0-9]*)-				vendor=atari-				;;-			*-vos*)-				vendor=stratus-				;;-		esac-		;;-esac--echo "$cpu-$vendor-${kernel:+$kernel-}$os"-exit--# Local variables:-# eval: (add-hook 'before-save-hook 'time-stamp)-# time-stamp-start: "timestamp='"-# time-stamp-format: "%:y-%02m-%02d"-# time-stamp-end: "'"-# End:
− configure 
@@ -1,34005 +0,0 @@-#! /bin/sh-# Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.71 for Haskell base package 1.0.-#-# Report bugs to <libraries@haskell.org>.-#-#-# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation,-# Inc.-#-#-# This configure script is free software; the Free Software Foundation-# gives unlimited permission to copy, distribute and modify it.-## -------------------- ##-## M4sh Initialization. ##-## -------------------- ##--# Be more Bourne compatible-DUALCASE=1; export DUALCASE # for MKS sh-as_nop=:-if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1-then :-  emulate sh-  NULLCMD=:-  # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which-  # is contrary to our usage.  Disable this feature.-  alias -g '${1+"$@"}'='"$@"'-  setopt NO_GLOB_SUBST-else $as_nop-  case `(set -o) 2>/dev/null` in #(-  *posix*) :-    set -o posix ;; #(-  *) :-     ;;-esac-fi----# Reset variables that may have inherited troublesome values from-# the environment.--# IFS needs to be set, to space, tab, and newline, in precisely that order.-# (If _AS_PATH_WALK were called with IFS unset, it would have the-# side effect of setting IFS to empty, thus disabling word splitting.)-# Quoting is to prevent editors from complaining about space-tab.-as_nl='-'-export as_nl-IFS=" ""	$as_nl"--PS1='$ '-PS2='> '-PS4='+ '--# Ensure predictable behavior from utilities with locale-dependent output.-LC_ALL=C-export LC_ALL-LANGUAGE=C-export LANGUAGE--# We cannot yet rely on "unset" to work, but we need these variables-# to be unset--not just set to an empty or harmless value--now, to-# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh).  This construct-# also avoids known problems related to "unset" and subshell syntax-# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).-for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH-do eval test \${$as_var+y} \-  && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :-done--# Ensure that fds 0, 1, and 2 are open.-if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi-if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi-if (exec 3>&2)            ; then :; else exec 2>/dev/null; fi--# The user is always right.-if ${PATH_SEPARATOR+false} :; then-  PATH_SEPARATOR=:-  (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {-    (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||-      PATH_SEPARATOR=';'-  }-fi---# Find who we are.  Look in the path if we contain no directory separator.-as_myself=-case $0 in #((-  *[\\/]* ) as_myself=$0 ;;-  *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    test -r "$as_dir$0" && as_myself=$as_dir$0 && break-  done-IFS=$as_save_IFS--     ;;-esac-# We did not find ourselves, most probably we were run as `sh COMMAND'-# in which case we are not to be found in the path.-if test "x$as_myself" = x; then-  as_myself=$0-fi-if test ! -f "$as_myself"; then-  printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2-  exit 1-fi---# Use a proper internal environment variable to ensure we don't fall-  # into an infinite loop, continuously re-executing ourselves.-  if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then-    _as_can_reexec=no; export _as_can_reexec;-    # We cannot yet assume a decent shell, so we have to provide a-# neutralization value for shells without unset; and this also-# works around shells that cannot unset nonexistent variables.-# Preserve -v and -x to the replacement shell.-BASH_ENV=/dev/null-ENV=/dev/null-(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV-case $- in # ((((-  *v*x* | *x*v* ) as_opts=-vx ;;-  *v* ) as_opts=-v ;;-  *x* ) as_opts=-x ;;-  * ) as_opts= ;;-esac-exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}-# Admittedly, this is quite paranoid, since all the known shells bail-# out after a failed `exec'.-printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2-exit 255-  fi-  # We don't want this to propagate to other subprocesses.-          { _as_can_reexec=; unset _as_can_reexec;}-if test "x$CONFIG_SHELL" = x; then-  as_bourne_compatible="as_nop=:-if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1-then :-  emulate sh-  NULLCMD=:-  # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which-  # is contrary to our usage.  Disable this feature.-  alias -g '\${1+\"\$@\"}'='\"\$@\"'-  setopt NO_GLOB_SUBST-else \$as_nop-  case \`(set -o) 2>/dev/null\` in #(-  *posix*) :-    set -o posix ;; #(-  *) :-     ;;-esac-fi-"-  as_required="as_fn_return () { (exit \$1); }-as_fn_success () { as_fn_return 0; }-as_fn_failure () { as_fn_return 1; }-as_fn_ret_success () { return 0; }-as_fn_ret_failure () { return 1; }--exitcode=0-as_fn_success || { exitcode=1; echo as_fn_success failed.; }-as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }-as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }-as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }-if ( set x; as_fn_ret_success y && test x = \"\$1\" )-then :--else \$as_nop-  exitcode=1; echo positional parameters were not saved.-fi-test x\$exitcode = x0 || exit 1-blah=\$(echo \$(echo blah))-test x\"\$blah\" = xblah || exit 1-test -x / || exit 1"-  as_suggested="  as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO-  as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO-  eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&-  test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1-test \$(( 1 + 1 )) = 2 || exit 1"-  if (eval "$as_required") 2>/dev/null-then :-  as_have_required=yes-else $as_nop-  as_have_required=no-fi-  if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null-then :--else $as_nop-  as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-as_found=false-for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-  as_found=:-  case $as_dir in #(-	 /*)-	   for as_base in sh bash ksh sh5; do-	     # Try only shells that exist, to save several forks.-	     as_shell=$as_dir$as_base-	     if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&-		    as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null-then :-  CONFIG_SHELL=$as_shell as_have_required=yes-		   if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null-then :-  break 2-fi-fi-	   done;;-       esac-  as_found=false-done-IFS=$as_save_IFS-if $as_found-then :--else $as_nop-  if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&-	      as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null-then :-  CONFIG_SHELL=$SHELL as_have_required=yes-fi-fi---      if test "x$CONFIG_SHELL" != x-then :-  export CONFIG_SHELL-             # We cannot yet assume a decent shell, so we have to provide a-# neutralization value for shells without unset; and this also-# works around shells that cannot unset nonexistent variables.-# Preserve -v and -x to the replacement shell.-BASH_ENV=/dev/null-ENV=/dev/null-(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV-case $- in # ((((-  *v*x* | *x*v* ) as_opts=-vx ;;-  *v* ) as_opts=-v ;;-  *x* ) as_opts=-x ;;-  * ) as_opts= ;;-esac-exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}-# Admittedly, this is quite paranoid, since all the known shells bail-# out after a failed `exec'.-printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2-exit 255-fi--    if test x$as_have_required = xno-then :-  printf "%s\n" "$0: This script requires a shell more modern than all"-  printf "%s\n" "$0: the shells that I found on your system."-  if test ${ZSH_VERSION+y} ; then-    printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should"-    printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later."-  else-    printf "%s\n" "$0: Please tell bug-autoconf@gnu.org and-$0: libraries@haskell.org about your system, including any-$0: error possibly output before this message. Then install-$0: a modern shell, or manually run the script under such a-$0: shell if you do have one."-  fi-  exit 1-fi-fi-fi-SHELL=${CONFIG_SHELL-/bin/sh}-export SHELL-# Unset more variables known to interfere with behavior of common tools.-CLICOLOR_FORCE= GREP_OPTIONS=-unset CLICOLOR_FORCE GREP_OPTIONS--## --------------------- ##-## M4sh Shell Functions. ##-## --------------------- ##-# as_fn_unset VAR-# ----------------# Portably unset VAR.-as_fn_unset ()-{-  { eval $1=; unset $1;}-}-as_unset=as_fn_unset---# as_fn_set_status STATUS-# ------------------------# Set $? to STATUS, without forking.-as_fn_set_status ()-{-  return $1-} # as_fn_set_status--# as_fn_exit STATUS-# ------------------# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.-as_fn_exit ()-{-  set +e-  as_fn_set_status $1-  exit $1-} # as_fn_exit-# as_fn_nop-# ----------# Do nothing but, unlike ":", preserve the value of $?.-as_fn_nop ()-{-  return $?-}-as_nop=as_fn_nop--# as_fn_mkdir_p-# --------------# Create "$as_dir" as a directory, including parents if necessary.-as_fn_mkdir_p ()-{--  case $as_dir in #(-  -*) as_dir=./$as_dir;;-  esac-  test -d "$as_dir" || eval $as_mkdir_p || {-    as_dirs=-    while :; do-      case $as_dir in #(-      *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(-      *) as_qdir=$as_dir;;-      esac-      as_dirs="'$as_qdir' $as_dirs"-      as_dir=`$as_dirname -- "$as_dir" ||-$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \-	 X"$as_dir" : 'X\(//\)[^/]' \| \-	 X"$as_dir" : 'X\(//\)$' \| \-	 X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||-printf "%s\n" X"$as_dir" |-    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)[^/].*/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\).*/{-	    s//\1/-	    q-	  }-	  s/.*/./; q'`-      test -d "$as_dir" && break-    done-    test -z "$as_dirs" || eval "mkdir $as_dirs"-  } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"---} # as_fn_mkdir_p--# as_fn_executable_p FILE-# ------------------------# Test if FILE is an executable regular file.-as_fn_executable_p ()-{-  test -f "$1" && test -x "$1"-} # as_fn_executable_p-# as_fn_append VAR VALUE-# -----------------------# Append the text in VALUE to the end of the definition contained in VAR. Take-# advantage of any shell optimizations that allow amortized linear growth over-# repeated appends, instead of the typical quadratic growth present in naive-# implementations.-if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null-then :-  eval 'as_fn_append ()-  {-    eval $1+=\$2-  }'-else $as_nop-  as_fn_append ()-  {-    eval $1=\$$1\$2-  }-fi # as_fn_append--# as_fn_arith ARG...-# -------------------# Perform arithmetic evaluation on the ARGs, and store the result in the-# global $as_val. Take advantage of shells that can avoid forks. The arguments-# must be portable across $(()) and expr.-if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null-then :-  eval 'as_fn_arith ()-  {-    as_val=$(( $* ))-  }'-else $as_nop-  as_fn_arith ()-  {-    as_val=`expr "$@" || test $? -eq 1`-  }-fi # as_fn_arith--# as_fn_nop-# ----------# Do nothing but, unlike ":", preserve the value of $?.-as_fn_nop ()-{-  return $?-}-as_nop=as_fn_nop--# as_fn_error STATUS ERROR [LINENO LOG_FD]-# -----------------------------------------# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are-# provided, also output the error to LOG_FD, referencing LINENO. Then exit the-# script with STATUS, using 1 if that was 0.-as_fn_error ()-{-  as_status=$1; test $as_status -eq 0 && as_status=1-  if test "$4"; then-    as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4-  fi-  printf "%s\n" "$as_me: error: $2" >&2-  as_fn_exit $as_status-} # as_fn_error--if expr a : '\(a\)' >/dev/null 2>&1 &&-   test "X`expr 00001 : '.*\(...\)'`" = X001; then-  as_expr=expr-else-  as_expr=false-fi--if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then-  as_basename=basename-else-  as_basename=false-fi--if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then-  as_dirname=dirname-else-  as_dirname=false-fi--as_me=`$as_basename -- "$0" ||-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \-	 X"$0" : 'X\(//\)$' \| \-	 X"$0" : 'X\(/\)' \| . 2>/dev/null ||-printf "%s\n" X/"$0" |-    sed '/^.*\/\([^/][^/]*\)\/*$/{-	    s//\1/-	    q-	  }-	  /^X\/\(\/\/\)$/{-	    s//\1/-	    q-	  }-	  /^X\/\(\/\).*/{-	    s//\1/-	    q-	  }-	  s/.*/./; q'`--# Avoid depending upon Character Ranges.-as_cr_letters='abcdefghijklmnopqrstuvwxyz'-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'-as_cr_Letters=$as_cr_letters$as_cr_LETTERS-as_cr_digits='0123456789'-as_cr_alnum=$as_cr_Letters$as_cr_digits---  as_lineno_1=$LINENO as_lineno_1a=$LINENO-  as_lineno_2=$LINENO as_lineno_2a=$LINENO-  eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&-  test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {-  # Blame Lee E. McMahon (1931-1989) for sed's syntax.  :-)-  sed -n '-    p-    /[$]LINENO/=-  ' <$as_myself |-    sed '-      s/[$]LINENO.*/&-/-      t lineno-      b-      :lineno-      N-      :loop-      s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/-      t loop-      s/-\n.*//-    ' >$as_me.lineno &&-  chmod +x "$as_me.lineno" ||-    { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }--  # If we had to re-execute with $CONFIG_SHELL, we're ensured to have-  # already done that, so ensure we don't try to do so again and fall-  # in an infinite loop.  This has already happened in practice.-  _as_can_reexec=no; export _as_can_reexec-  # Don't try to exec as it changes $[0], causing all sort of problems-  # (the dirname of $[0] is not the place where we might find the-  # original and so on.  Autoconf is especially sensitive to this).-  . "./$as_me.lineno"-  # Exit status is that of the last command.-  exit-}---# Determine whether it's possible to make 'echo' print without a newline.-# These variables are no longer used directly by Autoconf, but are AC_SUBSTed-# for compatibility with existing Makefiles.-ECHO_C= ECHO_N= ECHO_T=-case `echo -n x` in #(((((--n*)-  case `echo 'xy\c'` in-  *c*) ECHO_T='	';;	# ECHO_T is single tab character.-  xy)  ECHO_C='\c';;-  *)   echo `echo ksh88 bug on AIX 6.1` > /dev/null-       ECHO_T='	';;-  esac;;-*)-  ECHO_N='-n';;-esac--# For backward compatibility with old third-party macros, we provide-# the shell variables $as_echo and $as_echo_n.  New code should use-# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.-as_echo='printf %s\n'-as_echo_n='printf %s'---rm -f conf$$ conf$$.exe conf$$.file-if test -d conf$$.dir; then-  rm -f conf$$.dir/conf$$.file-else-  rm -f conf$$.dir-  mkdir conf$$.dir 2>/dev/null-fi-if (echo >conf$$.file) 2>/dev/null; then-  if ln -s conf$$.file conf$$ 2>/dev/null; then-    as_ln_s='ln -s'-    # ... but there are two gotchas:-    # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.-    # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.-    # In both cases, we have to default to `cp -pR'.-    ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||-      as_ln_s='cp -pR'-  elif ln conf$$.file conf$$ 2>/dev/null; then-    as_ln_s=ln-  else-    as_ln_s='cp -pR'-  fi-else-  as_ln_s='cp -pR'-fi-rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file-rmdir conf$$.dir 2>/dev/null--if mkdir -p . 2>/dev/null; then-  as_mkdir_p='mkdir -p "$as_dir"'-else-  test -d ./-p && rmdir ./-p-  as_mkdir_p=false-fi--as_test_x='test -x'-as_executable_p=as_fn_executable_p--# Sed expression to map a string onto a valid CPP name.-as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"--# Sed expression to map a string onto a valid variable name.-as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"---test -n "$DJDIR" || exec 7<&0 </dev/null-exec 6>&1--# Name of the host.-# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status,-# so uname gets run too.-ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`--#-# Initializations.-#-ac_default_prefix=/usr/local-ac_clean_files=-ac_config_libobj_dir=.-LIBOBJS=-cross_compiling=no-subdirs=-MFLAGS=-MAKEFLAGS=--# Identity of this package.-PACKAGE_NAME='Haskell base package'-PACKAGE_TARNAME='base'-PACKAGE_VERSION='1.0'-PACKAGE_STRING='Haskell base package 1.0'-PACKAGE_BUGREPORT='libraries@haskell.org'-PACKAGE_URL=''--ac_unique_file="include/HsBase.h"-# Factoring default headers for most tests.-ac_includes_default="\-#include <stddef.h>-#ifdef HAVE_STDIO_H-# include <stdio.h>-#endif-#ifdef HAVE_STDLIB_H-# include <stdlib.h>-#endif-#ifdef HAVE_STRING_H-# include <string.h>-#endif-#ifdef HAVE_INTTYPES_H-# include <inttypes.h>-#endif-#ifdef HAVE_STDINT_H-# include <stdint.h>-#endif-#ifdef HAVE_STRINGS_H-# include <strings.h>-#endif-#ifdef HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif-#ifdef HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif-#ifdef HAVE_UNISTD_H-# include <unistd.h>-#endif"--ac_header_c_list=-ac_subst_vars='LTLIBOBJS-LIBOBJS-EXTRA_LIBS-ICONV_LIB_DIRS-ICONV_INCLUDE_DIRS-EGREP-GREP-CPP-OBJEXT-EXEEXT-ac_ct_CC-CPPFLAGS-LDFLAGS-CFLAGS-CC-target_alias-host_alias-build_alias-LIBS-ECHO_T-ECHO_N-ECHO_C-DEFS-mandir-localedir-libdir-psdir-pdfdir-dvidir-htmldir-infodir-docdir-oldincludedir-includedir-runstatedir-localstatedir-sharedstatedir-sysconfdir-datadir-datarootdir-libexecdir-sbindir-bindir-program_transform_name-prefix-exec_prefix-PACKAGE_URL-PACKAGE_BUGREPORT-PACKAGE_STRING-PACKAGE_VERSION-PACKAGE_TARNAME-PACKAGE_NAME-PATH_SEPARATOR-SHELL'-ac_subst_files=''-ac_user_opts='-enable_option_checking-enable_largefile-with_iconv_includes-with_iconv_libraries-with_libcharset-'-      ac_precious_vars='build_alias-host_alias-target_alias-CC-CFLAGS-LDFLAGS-LIBS-CPPFLAGS-CPP'---# Initialize some variables set by options.-ac_init_help=-ac_init_version=false-ac_unrecognized_opts=-ac_unrecognized_sep=-# The variables have the same names as the options, with-# dashes changed to underlines.-cache_file=/dev/null-exec_prefix=NONE-no_create=-no_recursion=-prefix=NONE-program_prefix=NONE-program_suffix=NONE-program_transform_name=s,x,x,-silent=-site=-srcdir=-verbose=-x_includes=NONE-x_libraries=NONE--# Installation directory options.-# These are left unexpanded so users can "make install exec_prefix=/foo"-# and all the variables that are supposed to be based on exec_prefix-# by default will actually change.-# Use braces instead of parens because sh, perl, etc. also accept them.-# (The list follows the same order as the GNU Coding Standards.)-bindir='${exec_prefix}/bin'-sbindir='${exec_prefix}/sbin'-libexecdir='${exec_prefix}/libexec'-datarootdir='${prefix}/share'-datadir='${datarootdir}'-sysconfdir='${prefix}/etc'-sharedstatedir='${prefix}/com'-localstatedir='${prefix}/var'-runstatedir='${localstatedir}/run'-includedir='${prefix}/include'-oldincludedir='/usr/include'-docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'-infodir='${datarootdir}/info'-htmldir='${docdir}'-dvidir='${docdir}'-pdfdir='${docdir}'-psdir='${docdir}'-libdir='${exec_prefix}/lib'-localedir='${datarootdir}/locale'-mandir='${datarootdir}/man'--ac_prev=-ac_dashdash=-for ac_option-do-  # If the previous option needs an argument, assign it.-  if test -n "$ac_prev"; then-    eval $ac_prev=\$ac_option-    ac_prev=-    continue-  fi--  case $ac_option in-  *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;-  *=)   ac_optarg= ;;-  *)    ac_optarg=yes ;;-  esac--  case $ac_dashdash$ac_option in-  --)-    ac_dashdash=yes ;;--  -bindir | --bindir | --bindi | --bind | --bin | --bi)-    ac_prev=bindir ;;-  -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)-    bindir=$ac_optarg ;;--  -build | --build | --buil | --bui | --bu)-    ac_prev=build_alias ;;-  -build=* | --build=* | --buil=* | --bui=* | --bu=*)-    build_alias=$ac_optarg ;;--  -cache-file | --cache-file | --cache-fil | --cache-fi \-  | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)-    ac_prev=cache_file ;;-  -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \-  | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)-    cache_file=$ac_optarg ;;--  --config-cache | -C)-    cache_file=config.cache ;;--  -datadir | --datadir | --datadi | --datad)-    ac_prev=datadir ;;-  -datadir=* | --datadir=* | --datadi=* | --datad=*)-    datadir=$ac_optarg ;;--  -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \-  | --dataroo | --dataro | --datar)-    ac_prev=datarootdir ;;-  -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \-  | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)-    datarootdir=$ac_optarg ;;--  -disable-* | --disable-*)-    ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`-    # Reject names that are not valid shell variable names.-    expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&-      as_fn_error $? "invalid feature name: \`$ac_useropt'"-    ac_useropt_orig=$ac_useropt-    ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`-    case $ac_user_opts in-      *"-"enable_$ac_useropt"-"*) ;;-      *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"-	 ac_unrecognized_sep=', ';;-    esac-    eval enable_$ac_useropt=no ;;--  -docdir | --docdir | --docdi | --doc | --do)-    ac_prev=docdir ;;-  -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)-    docdir=$ac_optarg ;;--  -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)-    ac_prev=dvidir ;;-  -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)-    dvidir=$ac_optarg ;;--  -enable-* | --enable-*)-    ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`-    # Reject names that are not valid shell variable names.-    expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&-      as_fn_error $? "invalid feature name: \`$ac_useropt'"-    ac_useropt_orig=$ac_useropt-    ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`-    case $ac_user_opts in-      *"-"enable_$ac_useropt"-"*) ;;-      *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"-	 ac_unrecognized_sep=', ';;-    esac-    eval enable_$ac_useropt=\$ac_optarg ;;--  -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \-  | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \-  | --exec | --exe | --ex)-    ac_prev=exec_prefix ;;-  -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \-  | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \-  | --exec=* | --exe=* | --ex=*)-    exec_prefix=$ac_optarg ;;--  -gas | --gas | --ga | --g)-    # Obsolete; use --with-gas.-    with_gas=yes ;;--  -help | --help | --hel | --he | -h)-    ac_init_help=long ;;-  -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)-    ac_init_help=recursive ;;-  -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)-    ac_init_help=short ;;--  -host | --host | --hos | --ho)-    ac_prev=host_alias ;;-  -host=* | --host=* | --hos=* | --ho=*)-    host_alias=$ac_optarg ;;--  -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)-    ac_prev=htmldir ;;-  -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \-  | --ht=*)-    htmldir=$ac_optarg ;;--  -includedir | --includedir | --includedi | --included | --include \-  | --includ | --inclu | --incl | --inc)-    ac_prev=includedir ;;-  -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \-  | --includ=* | --inclu=* | --incl=* | --inc=*)-    includedir=$ac_optarg ;;--  -infodir | --infodir | --infodi | --infod | --info | --inf)-    ac_prev=infodir ;;-  -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)-    infodir=$ac_optarg ;;--  -libdir | --libdir | --libdi | --libd)-    ac_prev=libdir ;;-  -libdir=* | --libdir=* | --libdi=* | --libd=*)-    libdir=$ac_optarg ;;--  -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \-  | --libexe | --libex | --libe)-    ac_prev=libexecdir ;;-  -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \-  | --libexe=* | --libex=* | --libe=*)-    libexecdir=$ac_optarg ;;--  -localedir | --localedir | --localedi | --localed | --locale)-    ac_prev=localedir ;;-  -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)-    localedir=$ac_optarg ;;--  -localstatedir | --localstatedir | --localstatedi | --localstated \-  | --localstate | --localstat | --localsta | --localst | --locals)-    ac_prev=localstatedir ;;-  -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \-  | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)-    localstatedir=$ac_optarg ;;--  -mandir | --mandir | --mandi | --mand | --man | --ma | --m)-    ac_prev=mandir ;;-  -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)-    mandir=$ac_optarg ;;--  -nfp | --nfp | --nf)-    # Obsolete; use --without-fp.-    with_fp=no ;;--  -no-create | --no-create | --no-creat | --no-crea | --no-cre \-  | --no-cr | --no-c | -n)-    no_create=yes ;;--  -no-recursion | --no-recursion | --no-recursio | --no-recursi \-  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)-    no_recursion=yes ;;--  -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \-  | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \-  | --oldin | --oldi | --old | --ol | --o)-    ac_prev=oldincludedir ;;-  -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \-  | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \-  | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)-    oldincludedir=$ac_optarg ;;--  -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)-    ac_prev=prefix ;;-  -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)-    prefix=$ac_optarg ;;--  -program-prefix | --program-prefix | --program-prefi | --program-pref \-  | --program-pre | --program-pr | --program-p)-    ac_prev=program_prefix ;;-  -program-prefix=* | --program-prefix=* | --program-prefi=* \-  | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)-    program_prefix=$ac_optarg ;;--  -program-suffix | --program-suffix | --program-suffi | --program-suff \-  | --program-suf | --program-su | --program-s)-    ac_prev=program_suffix ;;-  -program-suffix=* | --program-suffix=* | --program-suffi=* \-  | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)-    program_suffix=$ac_optarg ;;--  -program-transform-name | --program-transform-name \-  | --program-transform-nam | --program-transform-na \-  | --program-transform-n | --program-transform- \-  | --program-transform | --program-transfor \-  | --program-transfo | --program-transf \-  | --program-trans | --program-tran \-  | --progr-tra | --program-tr | --program-t)-    ac_prev=program_transform_name ;;-  -program-transform-name=* | --program-transform-name=* \-  | --program-transform-nam=* | --program-transform-na=* \-  | --program-transform-n=* | --program-transform-=* \-  | --program-transform=* | --program-transfor=* \-  | --program-transfo=* | --program-transf=* \-  | --program-trans=* | --program-tran=* \-  | --progr-tra=* | --program-tr=* | --program-t=*)-    program_transform_name=$ac_optarg ;;--  -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)-    ac_prev=pdfdir ;;-  -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)-    pdfdir=$ac_optarg ;;--  -psdir | --psdir | --psdi | --psd | --ps)-    ac_prev=psdir ;;-  -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)-    psdir=$ac_optarg ;;--  -q | -quiet | --quiet | --quie | --qui | --qu | --q \-  | -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=* \-  | --sbi=* | --sb=*)-    sbindir=$ac_optarg ;;--  -sharedstatedir | --sharedstatedir | --sharedstatedi \-  | --sharedstated | --sharedstate | --sharedstat | --sharedsta \-  | --sharedst | --shareds | --shared | --share | --shar \-  | --sha | --sh)-    ac_prev=sharedstatedir ;;-  -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \-  | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \-  | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \-  | --sha=* | --sh=*)-    sharedstatedir=$ac_optarg ;;--  -site | --site | --sit)-    ac_prev=site ;;-  -site=* | --site=* | --sit=*)-    site=$ac_optarg ;;--  -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)-    ac_prev=srcdir ;;-  -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)-    srcdir=$ac_optarg ;;--  -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \-  | --syscon | --sysco | --sysc | --sys | --sy)-    ac_prev=sysconfdir ;;-  -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \-  | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)-    sysconfdir=$ac_optarg ;;--  -target | --target | --targe | --targ | --tar | --ta | --t)-    ac_prev=target_alias ;;-  -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)-    target_alias=$ac_optarg ;;--  -v | -verbose | --verbose | --verbos | --verbo | --verb)-    verbose=yes ;;--  -version | --version | --versio | --versi | --vers | -V)-    ac_init_version=: ;;--  -with-* | --with-*)-    ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`-    # Reject names that are not valid shell variable names.-    expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&-      as_fn_error $? "invalid package name: \`$ac_useropt'"-    ac_useropt_orig=$ac_useropt-    ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`-    case $ac_user_opts in-      *"-"with_$ac_useropt"-"*) ;;-      *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"-	 ac_unrecognized_sep=', ';;-    esac-    eval with_$ac_useropt=\$ac_optarg ;;--  -without-* | --without-*)-    ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`-    # Reject names that are not valid shell variable names.-    expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&-      as_fn_error $? "invalid package name: \`$ac_useropt'"-    ac_useropt_orig=$ac_useropt-    ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`-    case $ac_user_opts in-      *"-"with_$ac_useropt"-"*) ;;-      *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"-	 ac_unrecognized_sep=', ';;-    esac-    eval with_$ac_useropt=no ;;--  --x)-    # Obsolete; use --with-x.-    with_x=yes ;;--  -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \-  | --x-incl | --x-inc | --x-in | --x-i)-    ac_prev=x_includes ;;-  -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \-  | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)-    x_includes=$ac_optarg ;;--  -x-libraries | --x-libraries | --x-librarie | --x-librari \-  | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)-    ac_prev=x_libraries ;;-  -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \-  | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)-    x_libraries=$ac_optarg ;;--  -*) as_fn_error $? "unrecognized option: \`$ac_option'-Try \`$0 --help' for more information"-    ;;--  *=*)-    ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`-    # Reject names that are not valid shell variable names.-    case $ac_envvar in #(-      '' | [0-9]* | *[!_$as_cr_alnum]* )-      as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;-    esac-    eval $ac_envvar=\$ac_optarg-    export $ac_envvar ;;--  *)-    # FIXME: should be removed in autoconf 3.0.-    printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2-    expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&-      printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2-    : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"-    ;;--  esac-done--if test -n "$ac_prev"; then-  ac_option=--`echo $ac_prev | sed 's/_/-/g'`-  as_fn_error $? "missing argument to $ac_option"-fi--if test -n "$ac_unrecognized_opts"; then-  case $enable_option_checking in-    no) ;;-    fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;-    *)     printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;-  esac-fi--# Check all directory arguments for consistency.-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 runstatedir-do-  eval ac_val=\$$ac_var-  # Remove trailing slashes.-  case $ac_val in-    */ )-      ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`-      eval $ac_var=\$ac_val;;-  esac-  # Be sure to have absolute directory names.-  case $ac_val in-    [\\/$]* | ?:[\\/]* )  continue;;-    NONE | '' ) case $ac_var in *prefix ) continue;; esac;;-  esac-  as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"-done--# There might be people who depend on the old broken behavior: `$host'-# used to hold the argument of --host etc.-# FIXME: To remove some day.-build=$build_alias-host=$host_alias-target=$target_alias--# FIXME: To remove some day.-if test "x$host_alias" != x; then-  if test "x$build_alias" = x; then-    cross_compiling=maybe-  elif test "x$build_alias" != "x$host_alias"; then-    cross_compiling=yes-  fi-fi--ac_tool_prefix=-test -n "$host_alias" && ac_tool_prefix=$host_alias---test "$silent" = yes && exec 6>/dev/null---ac_pwd=`pwd` && test -n "$ac_pwd" &&-ac_ls_di=`ls -di .` &&-ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||-  as_fn_error $? "working directory cannot be determined"-test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||-  as_fn_error $? "pwd does not report name of working directory"---# Find the source files, if location was not specified.-if test -z "$srcdir"; then-  ac_srcdir_defaulted=yes-  # Try the directory containing this script, then the parent directory.-  ac_confdir=`$as_dirname -- "$as_myself" ||-$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \-	 X"$as_myself" : 'X\(//\)[^/]' \| \-	 X"$as_myself" : 'X\(//\)$' \| \-	 X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||-printf "%s\n" X"$as_myself" |-    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)[^/].*/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\).*/{-	    s//\1/-	    q-	  }-	  s/.*/./; q'`-  srcdir=$ac_confdir-  if test ! -r "$srcdir/$ac_unique_file"; then-    srcdir=..-  fi-else-  ac_srcdir_defaulted=no-fi-if test ! -r "$srcdir/$ac_unique_file"; then-  test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."-  as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"-fi-ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"-ac_abs_confdir=`(-	cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"-	pwd)`-# When building in place, set srcdir=.-if test "$ac_abs_confdir" = "$ac_pwd"; then-  srcdir=.-fi-# Remove unnecessary trailing slashes from srcdir.-# Double slashes in file names in object file debugging info-# mess up M-x gdb in Emacs.-case $srcdir in-*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;-esac-for ac_var in $ac_precious_vars; do-  eval ac_env_${ac_var}_set=\${${ac_var}+set}-  eval ac_env_${ac_var}_value=\$${ac_var}-  eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}-  eval ac_cv_env_${ac_var}_value=\$${ac_var}-done--#-# Report the --help message.-#-if test "$ac_init_help" = "long"; then-  # Omit some internal or obsolete options to make the list less imposing.-  # This message is too long to be a string in the A/UX 3.1 sh.-  cat <<_ACEOF-\`configure' configures Haskell base package 1.0 to adapt to many kinds of systems.--Usage: $0 [OPTION]... [VAR=VALUE]...--To assign environment variables (e.g., CC, CFLAGS...), specify them as-VAR=VALUE.  See below for descriptions of some of the useful variables.--Defaults for the options are specified in brackets.--Configuration:-  -h, --help              display this help and exit-      --help=short        display options specific to this package-      --help=recursive    display the short help of all the included packages-  -V, --version           display version information and exit-  -q, --quiet, --silent   do not print \`checking ...' messages-      --cache-file=FILE   cache test results in FILE [disabled]-  -C, --config-cache      alias for \`--cache-file=config.cache'-  -n, --no-create         do not create output files-      --srcdir=DIR        find the sources in DIR [configure dir or \`..']--Installation directories:-  --prefix=PREFIX         install architecture-independent files in PREFIX-                          [$ac_default_prefix]-  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX-                          [PREFIX]--By default, \`make install' will install all the files in-\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc.  You can specify-an installation prefix other than \`$ac_default_prefix' using \`--prefix',-for instance \`--prefix=\$HOME'.--For better control, use the options below.--Fine tuning of the installation directories:-  --bindir=DIR            user executables [EPREFIX/bin]-  --sbindir=DIR           system admin executables [EPREFIX/sbin]-  --libexecdir=DIR        program executables [EPREFIX/libexec]-  --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]-  --datarootdir=DIR       read-only arch.-independent data root [PREFIX/share]-  --datadir=DIR           read-only architecture-independent data [DATAROOTDIR]-  --infodir=DIR           info documentation [DATAROOTDIR/info]-  --localedir=DIR         locale-dependent data [DATAROOTDIR/locale]-  --mandir=DIR            man documentation [DATAROOTDIR/man]-  --docdir=DIR            documentation root [DATAROOTDIR/doc/base]-  --htmldir=DIR           html documentation [DOCDIR]-  --dvidir=DIR            dvi documentation [DOCDIR]-  --pdfdir=DIR            pdf documentation [DOCDIR]-  --psdir=DIR             ps documentation [DOCDIR]-_ACEOF--  cat <<\_ACEOF-_ACEOF-fi--if test -n "$ac_init_help"; then-  case $ac_init_help in-     short | recursive ) echo "Configuration of Haskell base package 1.0:";;-   esac-  cat <<\_ACEOF--Optional Features:-  --disable-option-checking  ignore unrecognized --enable/--with options-  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)-  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]-  --disable-largefile     omit support for large files--Optional Packages:-  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]-  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)-  --with-iconv-includes   directory containing iconv.h-  --with-iconv-libraries  directory containing iconv library-  --with-libcharset       Use libcharset [default=only if available]--Some influential environment variables:-  CC          C compiler command-  CFLAGS      C compiler flags-  LDFLAGS     linker flags, e.g. -L<lib dir> if you have libraries in a-              nonstandard directory <lib dir>-  LIBS        libraries to pass to the linker, e.g. -l<library>-  CPPFLAGS    (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if-              you have headers in a nonstandard directory <include dir>-  CPP         C preprocessor--Use these variables to override the choices made by `configure' or to help-it to find libraries and programs with nonstandard names/locations.--Report bugs to <libraries@haskell.org>.-_ACEOF-ac_status=$?-fi--if test "$ac_init_help" = "recursive"; then-  # If there are subdirs, report their specific --help.-  for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue-    test -d "$ac_dir" ||-      { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||-      continue-    ac_builddir=.--case "$ac_dir" in-.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;-*)-  ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`-  # A ".." for each directory in $ac_dir_suffix.-  ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`-  case $ac_top_builddir_sub in-  "") ac_top_builddir_sub=. ac_top_build_prefix= ;;-  *)  ac_top_build_prefix=$ac_top_builddir_sub/ ;;-  esac ;;-esac-ac_abs_top_builddir=$ac_pwd-ac_abs_builddir=$ac_pwd$ac_dir_suffix-# for backward compatibility:-ac_top_builddir=$ac_top_build_prefix--case $srcdir in-  .)  # We are building in place.-    ac_srcdir=.-    ac_top_srcdir=$ac_top_builddir_sub-    ac_abs_top_srcdir=$ac_pwd ;;-  [\\/]* | ?:[\\/]* )  # Absolute name.-    ac_srcdir=$srcdir$ac_dir_suffix;-    ac_top_srcdir=$srcdir-    ac_abs_top_srcdir=$srcdir ;;-  *) # Relative name.-    ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix-    ac_top_srcdir=$ac_top_build_prefix$srcdir-    ac_abs_top_srcdir=$ac_pwd/$srcdir ;;-esac-ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix--    cd "$ac_dir" || { ac_status=$?; continue; }-    # Check for configure.gnu first; this name is used for a wrapper for-    # Metaconfig's "Configure" on case-insensitive file systems.-    if test -f "$ac_srcdir/configure.gnu"; then-      echo &&-      $SHELL "$ac_srcdir/configure.gnu" --help=recursive-    elif test -f "$ac_srcdir/configure"; then-      echo &&-      $SHELL "$ac_srcdir/configure" --help=recursive-    else-      printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2-    fi || ac_status=$?-    cd "$ac_pwd" || { ac_status=$?; break; }-  done-fi--test -n "$ac_init_help" && exit $ac_status-if $ac_init_version; then-  cat <<\_ACEOF-Haskell base package configure 1.0-generated by GNU Autoconf 2.71--Copyright (C) 2021 Free Software Foundation, Inc.-This configure script is free software; the Free Software Foundation-gives unlimited permission to copy, distribute and modify it.-_ACEOF-  exit-fi--## ------------------------ ##-## Autoconf initialization. ##-## ------------------------ ##--# ac_fn_c_try_compile LINENO-# ---------------------------# Try to compile conftest.$ac_ext, and return whether this succeeded.-ac_fn_c_try_compile ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  rm -f conftest.$ac_objext conftest.beam-  if { { ac_try="$ac_compile"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_compile") 2>conftest.err-  ac_status=$?-  if test -s conftest.err; then-    grep -v '^ *+' conftest.err >conftest.er1-    cat conftest.er1 >&5-    mv -f conftest.er1 conftest.err-  fi-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; } && {-	 test -z "$ac_c_werror_flag" ||-	 test ! -s conftest.err-       } && test -s conftest.$ac_objext-then :-  ac_retval=0-else $as_nop-  printf "%s\n" "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--	ac_retval=1-fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno-  as_fn_set_status $ac_retval--} # ac_fn_c_try_compile--# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES-# --------------------------------------------------------# Tests whether HEADER exists and can be compiled using the include files in-# INCLUDES, setting the cache variable VAR accordingly.-ac_fn_c_check_header_compile ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5-printf %s "checking for $2... " >&6; }-if eval test \${$3+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-#include <$2>-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  eval "$3=yes"-else $as_nop-  eval "$3=no"-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-eval ac_res=\$$3-	       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5-printf "%s\n" "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno--} # ac_fn_c_check_header_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-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5-printf %s "checking for $2... " >&6; }-if eval test \${$3+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  eval "$3=no"-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-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 (void)-{-if (sizeof (($2)))-	    return 0;-  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :--else $as_nop-  eval "$3=yes"-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-eval ac_res=\$$3-	       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5-printf "%s\n" "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno--} # ac_fn_c_check_type--# ac_fn_c_try_link LINENO-# ------------------------# Try to link conftest.$ac_ext, and return whether this succeeded.-ac_fn_c_try_link ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext-  if { { ac_try="$ac_link"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_link") 2>conftest.err-  ac_status=$?-  if test -s conftest.err; then-    grep -v '^ *+' conftest.err >conftest.er1-    cat conftest.er1 >&5-    mv -f conftest.er1 conftest.err-  fi-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; } && {-	 test -z "$ac_c_werror_flag" ||-	 test ! -s conftest.err-       } && test -s conftest$ac_exeext && {-	 test "$cross_compiling" = yes ||-	 test -x conftest$ac_exeext-       }-then :-  ac_retval=0-else $as_nop-  printf "%s\n" "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--	ac_retval=1-fi-  # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information-  # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would-  # interfere with the next link command; also delete a directory that is-  # left behind by Apple's compiler.  We do this before executing the actions.-  rm -rf conftest.dSYM conftest_ipa8_conftest.oo-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno-  as_fn_set_status $ac_retval--} # ac_fn_c_try_link--# ac_fn_c_check_func LINENO FUNC VAR-# -----------------------------------# Tests whether FUNC exists, setting the cache variable VAR accordingly-ac_fn_c_check_func ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5-printf %s "checking for $2... " >&6; }-if eval test \${$3+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-/* Define $2 to an innocuous variant, in case <limits.h> declares $2.-   For example, HP-UX 11i <limits.h> declares gettimeofday.  */-#define $2 innocuous_$2--/* System header to define __stub macros and hopefully few prototypes,-   which can conflict with char $2 (); below.  */--#include <limits.h>-#undef $2--/* Override any GCC internal prototype to avoid an error.-   Use char because int might match the return type of a GCC-   builtin and then its argument prototype would still apply.  */-#ifdef __cplusplus-extern "C"-#endif-char $2 ();-/* The GNU C library defines this for functions which it implements-    to always fail with ENOSYS.  Some functions are actually named-    something starting with __ and the normal name is an alias.  */-#if defined __stub_$2 || defined __stub___$2-choke me-#endif--int-main (void)-{-return $2 ();-  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_link "$LINENO"-then :-  eval "$3=yes"-else $as_nop-  eval "$3=no"-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam \-    conftest$ac_exeext conftest.$ac_ext-fi-eval ac_res=\$$3-	       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5-printf "%s\n" "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno--} # ac_fn_c_check_func--# ac_fn_c_try_run LINENO-# -----------------------# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that-# executables *can* be run.-ac_fn_c_try_run ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  if { { ac_try="$ac_link"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_link") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'-  { { case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_try") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }; }-then :-  ac_retval=0-else $as_nop-  printf "%s\n" "$as_me: program exited with status $ac_status" >&5-       printf "%s\n" "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--       ac_retval=$ac_status-fi-  rm -rf conftest.dSYM conftest_ipa8_conftest.oo-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno-  as_fn_set_status $ac_retval--} # ac_fn_c_try_run--# ac_fn_c_compute_int LINENO EXPR VAR INCLUDES-# ---------------------------------------------# Tries to find the compile-time value of EXPR in a program that includes-# INCLUDES, setting VAR accordingly. Returns whether the value could be-# computed-ac_fn_c_compute_int ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  if test "$cross_compiling" = yes; then-    # Depending upon the size, compute the lo and hi bounds.-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-static int test_array [1 - 2 * !(($2) >= 0)];-test_array [0] = 0;-return test_array [0];--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_lo=0 ac_mid=0-  while :; do-    cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-static int test_array [1 - 2 * !(($2) <= $ac_mid)];-test_array [0] = 0;-return test_array [0];--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_hi=$ac_mid; break-else $as_nop-  as_fn_arith $ac_mid + 1 && ac_lo=$as_val-			if test $ac_lo -le $ac_mid; then-			  ac_lo= ac_hi=-			  break-			fi-			as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  done-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-static int test_array [1 - 2 * !(($2) < 0)];-test_array [0] = 0;-return test_array [0];--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_hi=-1 ac_mid=-1-  while :; do-    cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-static int test_array [1 - 2 * !(($2) >= $ac_mid)];-test_array [0] = 0;-return test_array [0];--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_lo=$ac_mid; break-else $as_nop-  as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val-			if test $ac_mid -le $ac_hi; then-			  ac_lo= ac_hi=-			  break-			fi-			as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  done-else $as_nop-  ac_lo= ac_hi=-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-# Binary search between lo and hi bounds.-while test "x$ac_lo" != "x$ac_hi"; do-  as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-static int test_array [1 - 2 * !(($2) <= $ac_mid)];-test_array [0] = 0;-return test_array [0];--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_hi=$ac_mid-else $as_nop-  as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-done-case $ac_lo in #((-?*) eval "$3=\$ac_lo"; ac_retval=0 ;;-'') ac_retval=1 ;;-esac-  else-    cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-static long int longval (void) { return $2; }-static unsigned long int ulongval (void) { return $2; }-#include <stdio.h>-#include <stdlib.h>-int-main (void)-{--  FILE *f = fopen ("conftest.val", "w");-  if (! f)-    return 1;-  if (($2) < 0)-    {-      long int i = longval ();-      if (i != ($2))-	return 1;-      fprintf (f, "%ld", i);-    }-  else-    {-      unsigned long int i = ulongval ();-      if (i != ($2))-	return 1;-      fprintf (f, "%lu", i);-    }-  /* Do not output a trailing newline, as this causes \r\n confusion-     on some platforms.  */-  return ferror (f) || fclose (f) != 0;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_run "$LINENO"-then :-  echo >>conftest.val; read $3 <conftest.val; ac_retval=0-else $as_nop-  ac_retval=1-fi-rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \-  conftest.$ac_objext conftest.beam conftest.$ac_ext-rm -f conftest.val--  fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno-  as_fn_set_status $ac_retval--} # ac_fn_c_compute_int--# ac_fn_check_decl LINENO SYMBOL VAR INCLUDES EXTRA-OPTIONS FLAG-VAR-# -------------------------------------------------------------------# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR-# accordingly. Pass EXTRA-OPTIONS to the compiler, using FLAG-VAR.-ac_fn_check_decl ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  as_decl_name=`echo $2|sed 's/ *(.*//'`-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5-printf %s "checking whether $as_decl_name is declared... " >&6; }-if eval test \${$3+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`-  eval ac_save_FLAGS=\$$6-  as_fn_append $6 " $5"-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$4-int-main (void)-{-#ifndef $as_decl_name-#ifdef __cplusplus-  (void) $as_decl_use;-#else-  (void) $as_decl_name;-#endif-#endif--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  eval "$3=yes"-else $as_nop-  eval "$3=no"-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  eval $6=\$ac_save_FLAGS--fi-eval ac_res=\$$3-	       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5-printf "%s\n" "$ac_res" >&6; }-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno--} # ac_fn_check_decl--# ac_fn_c_try_cpp LINENO-# -----------------------# Try to preprocess conftest.$ac_ext, and return whether this succeeded.-ac_fn_c_try_cpp ()-{-  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-  if { { ac_try="$ac_cpp conftest.$ac_ext"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err-  ac_status=$?-  if test -s conftest.err; then-    grep -v '^ *+' conftest.err >conftest.er1-    cat conftest.er1 >&5-    mv -f conftest.er1 conftest.err-  fi-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; } > conftest.i && {-	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||-	 test ! -s conftest.err-       }-then :-  ac_retval=0-else $as_nop-  printf "%s\n" "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--    ac_retval=1-fi-  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno-  as_fn_set_status $ac_retval--} # ac_fn_c_try_cpp-ac_configure_args_raw=-for ac_arg-do-  case $ac_arg in-  *\'*)-    ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;-  esac-  as_fn_append ac_configure_args_raw " '$ac_arg'"-done--case $ac_configure_args_raw in-  *$as_nl*)-    ac_safe_unquote= ;;-  *)-    ac_unsafe_z='|&;<>()$`\\"*?[ ''	' # This string ends in space, tab.-    ac_unsafe_a="$ac_unsafe_z#~"-    ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g"-    ac_configure_args_raw=`      printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;;-esac--cat >config.log <<_ACEOF-This file contains any messages produced by compilers while-running configure, to aid debugging if configure makes a mistake.--It was created by Haskell base package $as_me 1.0, which was-generated by GNU Autoconf 2.71.  Invocation command line was--  $ $0$ac_configure_args_raw--_ACEOF-exec 5>>config.log-{-cat <<_ASUNAME-## --------- ##-## Platform. ##-## --------- ##--hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`-uname -m = `(uname -m) 2>/dev/null || echo unknown`-uname -r = `(uname -r) 2>/dev/null || echo unknown`-uname -s = `(uname -s) 2>/dev/null || echo unknown`-uname -v = `(uname -v) 2>/dev/null || echo unknown`--/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`-/bin/uname -X     = `(/bin/uname -X) 2>/dev/null     || echo unknown`--/bin/arch              = `(/bin/arch) 2>/dev/null              || echo unknown`-/usr/bin/arch -k       = `(/usr/bin/arch -k) 2>/dev/null       || echo unknown`-/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`-/usr/bin/hostinfo      = `(/usr/bin/hostinfo) 2>/dev/null      || echo unknown`-/bin/machine           = `(/bin/machine) 2>/dev/null           || echo unknown`-/usr/bin/oslevel       = `(/usr/bin/oslevel) 2>/dev/null       || echo unknown`-/bin/universe          = `(/bin/universe) 2>/dev/null          || echo unknown`--_ASUNAME--as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    printf "%s\n" "PATH: $as_dir"-  done-IFS=$as_save_IFS--} >&5--cat >&5 <<_ACEOF---## ----------- ##-## Core tests. ##-## ----------- ##--_ACEOF---# Keep a trace of the command line.-# Strip out --no-create and --no-recursion so they do not pile up.-# Strip out --silent because we don't want to record it for future runs.-# Also quote any args containing shell meta-characters.-# Make two passes to allow for proper duplicate-argument suppression.-ac_configure_args=-ac_configure_args0=-ac_configure_args1=-ac_must_keep_next=false-for ac_pass in 1 2-do-  for ac_arg-  do-    case $ac_arg in-    -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;-    -q | -quiet | --quiet | --quie | --qui | --qu | --q \-    | -silent | --silent | --silen | --sile | --sil)-      continue ;;-    *\'*)-      ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;-    esac-    case $ac_pass in-    1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;-    2)-      as_fn_append ac_configure_args1 " '$ac_arg'"-      if test $ac_must_keep_next = true; then-	ac_must_keep_next=false # Got value, back to normal.-      else-	case $ac_arg in-	  *=* | --config-cache | -C | -disable-* | --disable-* \-	  | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \-	  | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \-	  | -with-* | --with-* | -without-* | --without-* | --x)-	    case "$ac_configure_args0 " in-	      "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;-	    esac-	    ;;-	  -* ) ac_must_keep_next=true ;;-	esac-      fi-      as_fn_append ac_configure_args " '$ac_arg'"-      ;;-    esac-  done-done-{ ac_configure_args0=; unset ac_configure_args0;}-{ ac_configure_args1=; unset ac_configure_args1;}--# When interrupted or exit'd, cleanup temporary files, and complete-# config.log.  We remove comments because anyway the quotes in there-# would cause problems or look ugly.-# WARNING: Use '\'' to represent an apostrophe within the trap.-# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.-trap 'exit_status=$?-  # Sanitize IFS.-  IFS=" ""	$as_nl"-  # Save into config.log some information that might help in debugging.-  {-    echo--    printf "%s\n" "## ---------------- ##-## Cache variables. ##-## ---------------- ##"-    echo-    # The following way of writing the cache mishandles newlines in values,-(-  for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do-    eval ac_val=\$$ac_var-    case $ac_val in #(-    *${as_nl}*)-      case $ac_var in #(-      *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5-printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;-      esac-      case $ac_var in #(-      _ | IFS | as_nl) ;; #(-      BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(-      *) { eval $ac_var=; unset $ac_var;} ;;-      esac ;;-    esac-  done-  (set) 2>&1 |-    case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(-    *${as_nl}ac_space=\ *)-      sed -n \-	"s/'\''/'\''\\\\'\'''\''/g;-	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"-      ;; #(-    *)-      sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"-      ;;-    esac |-    sort-)-    echo--    printf "%s\n" "## ----------------- ##-## Output variables. ##-## ----------------- ##"-    echo-    for ac_var in $ac_subst_vars-    do-      eval ac_val=\$$ac_var-      case $ac_val in-      *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;-      esac-      printf "%s\n" "$ac_var='\''$ac_val'\''"-    done | sort-    echo--    if test -n "$ac_subst_files"; then-      printf "%s\n" "## ------------------- ##-## File substitutions. ##-## ------------------- ##"-      echo-      for ac_var in $ac_subst_files-      do-	eval ac_val=\$$ac_var-	case $ac_val in-	*\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;-	esac-	printf "%s\n" "$ac_var='\''$ac_val'\''"-      done | sort-      echo-    fi--    if test -s confdefs.h; then-      printf "%s\n" "## ----------- ##-## confdefs.h. ##-## ----------- ##"-      echo-      cat confdefs.h-      echo-    fi-    test "$ac_signal" != 0 &&-      printf "%s\n" "$as_me: caught signal $ac_signal"-    printf "%s\n" "$as_me: exit $exit_status"-  } >&5-  rm -f core *.core core.conftest.* &&-    rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&-    exit $exit_status-' 0-for ac_signal in 1 2 13 15; do-  trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal-done-ac_signal=0--# confdefs.h avoids OS command line length limits that DEFS can exceed.-rm -f -r conftest* confdefs.h--printf "%s\n" "/* confdefs.h */" > confdefs.h--# Predefined preprocessor variables.--printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h--printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h--printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h--printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h--printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h--printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h---# Let the site file select an alternate cache file if it wants to.-# Prefer an explicitly selected file to automatically selected ones.-if test -n "$CONFIG_SITE"; then-  ac_site_files="$CONFIG_SITE"-elif test "x$prefix" != xNONE; then-  ac_site_files="$prefix/share/config.site $prefix/etc/config.site"-else-  ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"-fi--for ac_site_file in $ac_site_files-do-  case $ac_site_file in #(-  */*) :-     ;; #(-  *) :-    ac_site_file=./$ac_site_file ;;-esac-  if test -f "$ac_site_file" && test -r "$ac_site_file"; then-    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5-printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;}-    sed 's/^/| /' "$ac_site_file" >&5-    . "$ac_site_file" \-      || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "failed to load site script $ac_site_file-See \`config.log' for more details" "$LINENO" 5; }-  fi-done--if test -r "$cache_file"; then-  # Some versions of bash will fail to source /dev/null (special files-  # actually), so we avoid doing that.  DJGPP emulates it as a regular file.-  if test /dev/null != "$cache_file" && test -f "$cache_file"; then-    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5-printf "%s\n" "$as_me: loading cache $cache_file" >&6;}-    case $cache_file in-      [\\/]* | ?:[\\/]* ) . "$cache_file";;-      *)                      . "./$cache_file";;-    esac-  fi-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5-printf "%s\n" "$as_me: creating cache $cache_file" >&6;}-  >$cache_file-fi--# Test code for whether the C compiler supports C89 (global declarations)-ac_c_conftest_c89_globals='-/* Does the compiler advertise C89 conformance?-   Do not test the value of __STDC__, because some compilers set it to 0-   while being otherwise adequately conformant. */-#if !defined __STDC__-# error "Compiler does not advertise C89 conformance"-#endif--#include <stddef.h>-#include <stdarg.h>-struct stat;-/* Most of the following tests are stolen from RCS 5.7 src/conf.sh.  */-struct buf { int x; };-struct buf * (*rcsopen) (struct buf *, struct stat *, int);-static char *e (p, i)-     char **p;-     int i;-{-  return p[i];-}-static char *f (char * (*g) (char **, int), char **p, ...)-{-  char *s;-  va_list v;-  va_start (v,p);-  s = g (p, va_arg (v,int));-  va_end (v);-  return s;-}--/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default.  It has-   function prototypes and stuff, but not \xHH hex character constants.-   These do not provoke an error unfortunately, instead are silently treated-   as an "x".  The following induces an error, until -std is added to get-   proper ANSI mode.  Curiously \x00 != x always comes out true, for an-   array size at least.  It is necessary to write \x00 == 0 to get something-   that is true only with -std.  */-int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1];--/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters-   inside strings and character constants.  */-#define FOO(x) '\''x'\''-int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1];--int test (int i, double x);-struct s1 {int (*f) (int a);};-struct s2 {int (*f) (double a);};-int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int),-               int, int);'--# Test code for whether the C compiler supports C89 (body of main).-ac_c_conftest_c89_main='-ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]);-'--# Test code for whether the C compiler supports C99 (global declarations)-ac_c_conftest_c99_globals='-// Does the compiler advertise C99 conformance?-#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L-# error "Compiler does not advertise C99 conformance"-#endif--#include <stdbool.h>-extern int puts (const char *);-extern int printf (const char *, ...);-extern int dprintf (int, const char *, ...);-extern void *malloc (size_t);--// Check varargs macros.  These examples are taken from C99 6.10.3.5.-// dprintf is used instead of fprintf to avoid needing to declare-// FILE and stderr.-#define debug(...) dprintf (2, __VA_ARGS__)-#define showlist(...) puts (#__VA_ARGS__)-#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__))-static void-test_varargs_macros (void)-{-  int x = 1234;-  int y = 5678;-  debug ("Flag");-  debug ("X = %d\n", x);-  showlist (The first, second, and third items.);-  report (x>y, "x is %d but y is %d", x, y);-}--// Check long long types.-#define BIG64 18446744073709551615ull-#define BIG32 4294967295ul-#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0)-#if !BIG_OK-  #error "your preprocessor is broken"-#endif-#if BIG_OK-#else-  #error "your preprocessor is broken"-#endif-static long long int bignum = -9223372036854775807LL;-static unsigned long long int ubignum = BIG64;--struct incomplete_array-{-  int datasize;-  double data[];-};--struct named_init {-  int number;-  const wchar_t *name;-  double average;-};--typedef const char *ccp;--static inline int-test_restrict (ccp restrict text)-{-  // See if C++-style comments work.-  // Iterate through items via the restricted pointer.-  // Also check for declarations in for loops.-  for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i)-    continue;-  return 0;-}--// Check varargs and va_copy.-static bool-test_varargs (const char *format, ...)-{-  va_list args;-  va_start (args, format);-  va_list args_copy;-  va_copy (args_copy, args);--  const char *str = "";-  int number = 0;-  float fnumber = 0;--  while (*format)-    {-      switch (*format++)-	{-	case '\''s'\'': // string-	  str = va_arg (args_copy, const char *);-	  break;-	case '\''d'\'': // int-	  number = va_arg (args_copy, int);-	  break;-	case '\''f'\'': // float-	  fnumber = va_arg (args_copy, double);-	  break;-	default:-	  break;-	}-    }-  va_end (args_copy);-  va_end (args);--  return *str && number && fnumber;-}-'--# Test code for whether the C compiler supports C99 (body of main).-ac_c_conftest_c99_main='-  // Check bool.-  _Bool success = false;-  success |= (argc != 0);--  // Check restrict.-  if (test_restrict ("String literal") == 0)-    success = true;-  char *restrict newvar = "Another string";--  // Check varargs.-  success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234);-  test_varargs_macros ();--  // Check flexible array members.-  struct incomplete_array *ia =-    malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10));-  ia->datasize = 10;-  for (int i = 0; i < ia->datasize; ++i)-    ia->data[i] = i * 1.234;--  // Check named initializers.-  struct named_init ni = {-    .number = 34,-    .name = L"Test wide string",-    .average = 543.34343,-  };--  ni.number = 58;--  int dynamic_array[ni.number];-  dynamic_array[0] = argv[0][0];-  dynamic_array[ni.number - 1] = 543;--  // work around unused variable warnings-  ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\''-	 || dynamic_array[ni.number - 1] != 543);-'--# Test code for whether the C compiler supports C11 (global declarations)-ac_c_conftest_c11_globals='-// Does the compiler advertise C11 conformance?-#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L-# error "Compiler does not advertise C11 conformance"-#endif--// Check _Alignas.-char _Alignas (double) aligned_as_double;-char _Alignas (0) no_special_alignment;-extern char aligned_as_int;-char _Alignas (0) _Alignas (int) aligned_as_int;--// Check _Alignof.-enum-{-  int_alignment = _Alignof (int),-  int_array_alignment = _Alignof (int[100]),-  char_alignment = _Alignof (char)-};-_Static_assert (0 < -_Alignof (int), "_Alignof is signed");--// Check _Noreturn.-int _Noreturn does_not_return (void) { for (;;) continue; }--// Check _Static_assert.-struct test_static_assert-{-  int x;-  _Static_assert (sizeof (int) <= sizeof (long int),-                  "_Static_assert does not work in struct");-  long int y;-};--// Check UTF-8 literals.-#define u8 syntax error!-char const utf8_literal[] = u8"happens to be ASCII" "another string";--// Check duplicate typedefs.-typedef long *long_ptr;-typedef long int *long_ptr;-typedef long_ptr long_ptr;--// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1.-struct anonymous-{-  union {-    struct { int i; int j; };-    struct { int k; long int l; } w;-  };-  int m;-} v1;-'--# Test code for whether the C compiler supports C11 (body of main).-ac_c_conftest_c11_main='-  _Static_assert ((offsetof (struct anonymous, i)-		   == offsetof (struct anonymous, w.k)),-		  "Anonymous union alignment botch");-  v1.i = 2;-  v1.w.k = 5;-  ok |= v1.i != 5;-'--# Test code for whether the C compiler supports C11 (complete).-ac_c_conftest_c11_program="${ac_c_conftest_c89_globals}-${ac_c_conftest_c99_globals}-${ac_c_conftest_c11_globals}--int-main (int argc, char **argv)-{-  int ok = 0;-  ${ac_c_conftest_c89_main}-  ${ac_c_conftest_c99_main}-  ${ac_c_conftest_c11_main}-  return ok;-}-"--# Test code for whether the C compiler supports C99 (complete).-ac_c_conftest_c99_program="${ac_c_conftest_c89_globals}-${ac_c_conftest_c99_globals}--int-main (int argc, char **argv)-{-  int ok = 0;-  ${ac_c_conftest_c89_main}-  ${ac_c_conftest_c99_main}-  return ok;-}-"--# Test code for whether the C compiler supports C89 (complete).-ac_c_conftest_c89_program="${ac_c_conftest_c89_globals}--int-main (int argc, char **argv)-{-  int ok = 0;-  ${ac_c_conftest_c89_main}-  return ok;-}-"--as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H"-as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H"-as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H"-as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H"-as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H"-as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H"-as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H"-as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H"-as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H"-as_fn_append ac_header_c_list " wchar.h wchar_h HAVE_WCHAR_H"-as_fn_append ac_header_c_list " minix/config.h minix_config_h HAVE_MINIX_CONFIG_H"-# Check that the precious variables saved in the cache have kept the same-# value.-ac_cache_corrupted=false-for ac_var in $ac_precious_vars; do-  eval ac_old_set=\$ac_cv_env_${ac_var}_set-  eval ac_new_set=\$ac_env_${ac_var}_set-  eval ac_old_val=\$ac_cv_env_${ac_var}_value-  eval ac_new_val=\$ac_env_${ac_var}_value-  case $ac_old_set,$ac_new_set in-    set,)-      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5-printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}-      ac_cache_corrupted=: ;;-    ,set)-      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5-printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}-      ac_cache_corrupted=: ;;-    ,);;-    *)-      if test "x$ac_old_val" != "x$ac_new_val"; then-	# differences in whitespace do not lead to failure.-	ac_old_val_w=`echo x $ac_old_val`-	ac_new_val_w=`echo x $ac_new_val`-	if test "$ac_old_val_w" != "$ac_new_val_w"; then-	  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5-printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}-	  ac_cache_corrupted=:-	else-	  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5-printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}-	  eval $ac_var=\$ac_old_val-	fi-	{ printf "%s\n" "$as_me:${as_lineno-$LINENO}:   former value:  \`$ac_old_val'" >&5-printf "%s\n" "$as_me:   former value:  \`$ac_old_val'" >&2;}-	{ printf "%s\n" "$as_me:${as_lineno-$LINENO}:   current value: \`$ac_new_val'" >&5-printf "%s\n" "$as_me:   current value: \`$ac_new_val'" >&2;}-      fi;;-  esac-  # Pass precious variables to config.status.-  if test "$ac_new_set" = set; then-    case $ac_new_val in-    *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;-    *) ac_arg=$ac_var=$ac_new_val ;;-    esac-    case " $ac_configure_args " in-      *" '$ac_arg' "*) ;; # Avoid dups.  Use of quotes ensures accuracy.-      *) as_fn_append ac_configure_args " '$ac_arg'" ;;-    esac-  fi-done-if $ac_cache_corrupted; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5-printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;}-  as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file'-	    and start over" "$LINENO" 5-fi-## -------------------- ##-## Main body of script. ##-## -------------------- ##--ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu----# Safety check: Ensure that we are in the correct source directory.---ac_config_headers="$ac_config_headers include/HsBaseConfig.h include/EventConfig.h"------------ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu-if test -n "$ac_tool_prefix"; then-  # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.-set dummy ${ac_tool_prefix}gcc; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$CC"; then-  ac_cv_prog_CC="$CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_CC="${ac_tool_prefix}gcc"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-CC=$ac_cv_prog_CC-if test -n "$CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5-printf "%s\n" "$CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi---fi-if test -z "$ac_cv_prog_CC"; then-  ac_ct_CC=$CC-  # Extract the first word of "gcc", so it can be a program name with args.-set dummy gcc; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_ac_ct_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$ac_ct_CC"; then-  ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_ac_ct_CC="gcc"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-ac_ct_CC=$ac_cv_prog_ac_ct_CC-if test -n "$ac_ct_CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5-printf "%s\n" "$ac_ct_CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi--  if test "x$ac_ct_CC" = x; then-    CC=""-  else-    case $cross_compiling:$ac_tool_warned in-yes:)-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}-ac_tool_warned=yes ;;-esac-    CC=$ac_ct_CC-  fi-else-  CC="$ac_cv_prog_CC"-fi--if test -z "$CC"; then-          if test -n "$ac_tool_prefix"; then-    # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.-set dummy ${ac_tool_prefix}cc; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$CC"; then-  ac_cv_prog_CC="$CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_CC="${ac_tool_prefix}cc"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-CC=$ac_cv_prog_CC-if test -n "$CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5-printf "%s\n" "$CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi---  fi-fi-if test -z "$CC"; then-  # Extract the first word of "cc", so it can be a program name with args.-set dummy cc; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$CC"; then-  ac_cv_prog_CC="$CC" # Let the user override the test.-else-  ac_prog_rejected=no-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then-       ac_prog_rejected=yes-       continue-     fi-    ac_cv_prog_CC="cc"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--if test $ac_prog_rejected = yes; then-  # We found a bogon in the path, so make sure we never use it.-  set dummy $ac_cv_prog_CC-  shift-  if test $# != 0; then-    # We chose a different compiler from the bogus one.-    # However, it has the same basename, so the bogon will be chosen-    # first if we set CC to just the basename; use the full file name.-    shift-    ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@"-  fi-fi-fi-fi-CC=$ac_cv_prog_CC-if test -n "$CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5-printf "%s\n" "$CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi---fi-if test -z "$CC"; then-  if test -n "$ac_tool_prefix"; then-  for ac_prog in cl.exe-  do-    # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.-set dummy $ac_tool_prefix$ac_prog; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$CC"; then-  ac_cv_prog_CC="$CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_CC="$ac_tool_prefix$ac_prog"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-CC=$ac_cv_prog_CC-if test -n "$CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5-printf "%s\n" "$CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi---    test -n "$CC" && break-  done-fi-if test -z "$CC"; then-  ac_ct_CC=$CC-  for ac_prog in cl.exe-do-  # Extract the first word of "$ac_prog", so it can be a program name with args.-set dummy $ac_prog; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_ac_ct_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$ac_ct_CC"; then-  ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_ac_ct_CC="$ac_prog"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-ac_ct_CC=$ac_cv_prog_ac_ct_CC-if test -n "$ac_ct_CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5-printf "%s\n" "$ac_ct_CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi---  test -n "$ac_ct_CC" && break-done--  if test "x$ac_ct_CC" = x; then-    CC=""-  else-    case $cross_compiling:$ac_tool_warned in-yes:)-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}-ac_tool_warned=yes ;;-esac-    CC=$ac_ct_CC-  fi-fi--fi-if test -z "$CC"; then-  if test -n "$ac_tool_prefix"; then-  # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args.-set dummy ${ac_tool_prefix}clang; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$CC"; then-  ac_cv_prog_CC="$CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_CC="${ac_tool_prefix}clang"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-CC=$ac_cv_prog_CC-if test -n "$CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5-printf "%s\n" "$CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi---fi-if test -z "$ac_cv_prog_CC"; then-  ac_ct_CC=$CC-  # Extract the first word of "clang", so it can be a program name with args.-set dummy clang; ac_word=$2-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5-printf %s "checking for $ac_word... " >&6; }-if test ${ac_cv_prog_ac_ct_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -n "$ac_ct_CC"; then-  ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.-else-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_exec_ext in '' $ac_executable_extensions; do-  if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then-    ac_cv_prog_ac_ct_CC="clang"-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5-    break 2-  fi-done-  done-IFS=$as_save_IFS--fi-fi-ac_ct_CC=$ac_cv_prog_ac_ct_CC-if test -n "$ac_ct_CC"; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5-printf "%s\n" "$ac_ct_CC" >&6; }-else-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-fi--  if test "x$ac_ct_CC" = x; then-    CC=""-  else-    case $cross_compiling:$ac_tool_warned in-yes:)-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}-ac_tool_warned=yes ;;-esac-    CC=$ac_ct_CC-  fi-else-  CC="$ac_cv_prog_CC"-fi--fi---test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "no acceptable C compiler found in \$PATH-See \`config.log' for more details" "$LINENO" 5; }--# Provide some information about the compiler.-printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5-set X $ac_compile-ac_compiler=$2-for ac_option in --version -v -V -qversion -version; do-  { { ac_try="$ac_compiler $ac_option >&5"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_compiler $ac_option >&5") 2>conftest.err-  ac_status=$?-  if test -s conftest.err; then-    sed '10a\-... rest of stderr output deleted ...-         10q' conftest.err >conftest.er1-    cat conftest.er1 >&5-  fi-  rm -f conftest.er1 conftest.err-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }-done--cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{--  ;-  return 0;-}-_ACEOF-ac_clean_files_save=$ac_clean_files-ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"-# Try to create an executable without -o first, disregard a.out.-# It will help us diagnose broken compilers, and finding out an intuition-# of exeext.-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5-printf %s "checking whether the C compiler works... " >&6; }-ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'`--# The possible output files:-ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"--ac_rmfiles=-for ac_file in $ac_files-do-  case $ac_file in-    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;-    * ) ac_rmfiles="$ac_rmfiles $ac_file";;-  esac-done-rm -f $ac_rmfiles--if { { ac_try="$ac_link_default"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_link_default") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }-then :-  # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.-# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'-# in a Makefile.  We should not override ac_cv_exeext if it was cached,-# so that the user can short-circuit this test for compilers unknown to-# Autoconf.-for ac_file in $ac_files ''-do-  test -f "$ac_file" || continue-  case $ac_file in-    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )-	;;-    [ab].out )-	# We found the default executable, but exeext='' is most-	# certainly right.-	break;;-    *.* )-	if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no;-	then :; else-	   ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`-	fi-	# We set ac_cv_exeext here because the later test for it is not-	# safe: cross compilers may not add the suffix if given an `-o'-	# argument, so we may need to know it at that point already.-	# Even if this section looks crufty: it has the advantage of-	# actually working.-	break;;-    * )-	break;;-  esac-done-test "$ac_cv_exeext" = no && ac_cv_exeext=--else $as_nop-  ac_file=''-fi-if test -z "$ac_file"-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5-printf "%s\n" "no" >&6; }-printf "%s\n" "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error 77 "C compiler cannot create executables-See \`config.log' for more details" "$LINENO" 5; }-else $as_nop-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5-printf "%s\n" "yes" >&6; }-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5-printf %s "checking for C compiler default output file name... " >&6; }-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5-printf "%s\n" "$ac_file" >&6; }-ac_exeext=$ac_cv_exeext--rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out-ac_clean_files=$ac_clean_files_save-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5-printf %s "checking for suffix of executables... " >&6; }-if { { ac_try="$ac_link"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_link") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }-then :-  # If both `conftest.exe' and `conftest' are `present' (well, observable)-# catch `conftest.exe'.  For instance with Cygwin, `ls conftest' will-# work properly (i.e., refer to `conftest.exe'), while it won't with-# `rm'.-for ac_file in conftest.exe conftest conftest.*; do-  test -f "$ac_file" || continue-  case $ac_file in-    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;-    *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`-	  break;;-    * ) break;;-  esac-done-else $as_nop-  { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "cannot compute suffix of executables: cannot compile and link-See \`config.log' for more details" "$LINENO" 5; }-fi-rm -f conftest conftest$ac_cv_exeext-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5-printf "%s\n" "$ac_cv_exeext" >&6; }--rm -f conftest.$ac_ext-EXEEXT=$ac_cv_exeext-ac_exeext=$EXEEXT-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <stdio.h>-int-main (void)-{-FILE *f = fopen ("conftest.out", "w");- return ferror (f) || fclose (f) != 0;--  ;-  return 0;-}-_ACEOF-ac_clean_files="$ac_clean_files conftest.out"-# Check that the compiler produces executables we can run.  If not, either-# the compiler is broken, or we cross compile.-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5-printf %s "checking whether we are cross compiling... " >&6; }-if test "$cross_compiling" != yes; then-  { { ac_try="$ac_link"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_link") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }-  if { ac_try='./conftest$ac_cv_exeext'-  { { case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_try") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }; }; then-    cross_compiling=no-  else-    if test "$cross_compiling" = maybe; then-	cross_compiling=yes-    else-	{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error 77 "cannot run C compiled programs.-If you meant to cross compile, use \`--host'.-See \`config.log' for more details" "$LINENO" 5; }-    fi-  fi-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5-printf "%s\n" "$cross_compiling" >&6; }--rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out-ac_clean_files=$ac_clean_files_save-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5-printf %s "checking for suffix of object files... " >&6; }-if test ${ac_cv_objext+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{--  ;-  return 0;-}-_ACEOF-rm -f conftest.o conftest.obj-if { { ac_try="$ac_compile"-case "(($ac_try" in-  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;-  *) ac_try_echo=$ac_try;;-esac-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""-printf "%s\n" "$ac_try_echo"; } >&5-  (eval "$ac_compile") 2>&5-  ac_status=$?-  printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5-  test $ac_status = 0; }-then :-  for ac_file in conftest.o conftest.obj conftest.*; do-  test -f "$ac_file" || continue;-  case $ac_file in-    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;-    *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`-       break;;-  esac-done-else $as_nop-  printf "%s\n" "$as_me: failed program was:" >&5-sed 's/^/| /' conftest.$ac_ext >&5--{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "cannot compute suffix of object files: cannot compile-See \`config.log' for more details" "$LINENO" 5; }-fi-rm -f conftest.$ac_cv_objext conftest.$ac_ext-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5-printf "%s\n" "$ac_cv_objext" >&6; }-OBJEXT=$ac_cv_objext-ac_objext=$OBJEXT-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5-printf %s "checking whether the compiler supports GNU C... " >&6; }-if test ${ac_cv_c_compiler_gnu+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{-#ifndef __GNUC__-       choke me-#endif--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_compiler_gnu=yes-else $as_nop-  ac_compiler_gnu=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-ac_cv_c_compiler_gnu=$ac_compiler_gnu--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5-printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; }-ac_compiler_gnu=$ac_cv_c_compiler_gnu--if test $ac_compiler_gnu = yes; then-  GCC=yes-else-  GCC=-fi-ac_test_CFLAGS=${CFLAGS+y}-ac_save_CFLAGS=$CFLAGS-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5-printf %s "checking whether $CC accepts -g... " >&6; }-if test ${ac_cv_prog_cc_g+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_save_c_werror_flag=$ac_c_werror_flag-   ac_c_werror_flag=yes-   ac_cv_prog_cc_g=no-   CFLAGS="-g"-   cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_prog_cc_g=yes-else $as_nop-  CFLAGS=""-      cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :--else $as_nop-  ac_c_werror_flag=$ac_save_c_werror_flag-	 CFLAGS="-g"-	 cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_prog_cc_g=yes-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-   ac_c_werror_flag=$ac_save_c_werror_flag-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5-printf "%s\n" "$ac_cv_prog_cc_g" >&6; }-if test $ac_test_CFLAGS; then-  CFLAGS=$ac_save_CFLAGS-elif test $ac_cv_prog_cc_g = yes; then-  if test "$GCC" = yes; then-    CFLAGS="-g -O2"-  else-    CFLAGS="-g"-  fi-else-  if test "$GCC" = yes; then-    CFLAGS="-O2"-  else-    CFLAGS=-  fi-fi-ac_prog_cc_stdc=no-if test x$ac_prog_cc_stdc = xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5-printf %s "checking for $CC option to enable C11 features... " >&6; }-if test ${ac_cv_prog_cc_c11+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_cv_prog_cc_c11=no-ac_save_CC=$CC-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$ac_c_conftest_c11_program-_ACEOF-for ac_arg in '' -std=gnu11-do-  CC="$ac_save_CC $ac_arg"-  if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_prog_cc_c11=$ac_arg-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam-  test "x$ac_cv_prog_cc_c11" != "xno" && break-done-rm -f conftest.$ac_ext-CC=$ac_save_CC-fi--if test "x$ac_cv_prog_cc_c11" = xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5-printf "%s\n" "unsupported" >&6; }-else $as_nop-  if test "x$ac_cv_prog_cc_c11" = x-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5-printf "%s\n" "none needed" >&6; }-else $as_nop-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5-printf "%s\n" "$ac_cv_prog_cc_c11" >&6; }-     CC="$CC $ac_cv_prog_cc_c11"-fi-  ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11-  ac_prog_cc_stdc=c11-fi-fi-if test x$ac_prog_cc_stdc = xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5-printf %s "checking for $CC option to enable C99 features... " >&6; }-if test ${ac_cv_prog_cc_c99+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_cv_prog_cc_c99=no-ac_save_CC=$CC-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$ac_c_conftest_c99_program-_ACEOF-for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99=-do-  CC="$ac_save_CC $ac_arg"-  if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_prog_cc_c99=$ac_arg-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam-  test "x$ac_cv_prog_cc_c99" != "xno" && break-done-rm -f conftest.$ac_ext-CC=$ac_save_CC-fi--if test "x$ac_cv_prog_cc_c99" = xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5-printf "%s\n" "unsupported" >&6; }-else $as_nop-  if test "x$ac_cv_prog_cc_c99" = x-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5-printf "%s\n" "none needed" >&6; }-else $as_nop-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5-printf "%s\n" "$ac_cv_prog_cc_c99" >&6; }-     CC="$CC $ac_cv_prog_cc_c99"-fi-  ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99-  ac_prog_cc_stdc=c99-fi-fi-if test x$ac_prog_cc_stdc = xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5-printf %s "checking for $CC option to enable C89 features... " >&6; }-if test ${ac_cv_prog_cc_c89+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_cv_prog_cc_c89=no-ac_save_CC=$CC-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-$ac_c_conftest_c89_program-_ACEOF-for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"-do-  CC="$ac_save_CC $ac_arg"-  if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_prog_cc_c89=$ac_arg-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam-  test "x$ac_cv_prog_cc_c89" != "xno" && break-done-rm -f conftest.$ac_ext-CC=$ac_save_CC-fi--if test "x$ac_cv_prog_cc_c89" = xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5-printf "%s\n" "unsupported" >&6; }-else $as_nop-  if test "x$ac_cv_prog_cc_c89" = x-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5-printf "%s\n" "none needed" >&6; }-else $as_nop-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5-printf "%s\n" "$ac_cv_prog_cc_c89" >&6; }-     CC="$CC $ac_cv_prog_cc_c89"-fi-  ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89-  ac_prog_cc_stdc=c89-fi-fi--ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu---ac_header= ac_cache=-for ac_item in $ac_header_c_list-do-  if test $ac_cache; then-    ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default"-    if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then-      printf "%s\n" "#define $ac_item 1" >> confdefs.h-    fi-    ac_header= ac_cache=-  elif test $ac_header; then-    ac_cache=$ac_item-  else-    ac_header=$ac_item-  fi-done---------if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes-then :--printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h--fi-------  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether it is safe to define __EXTENSIONS__" >&5-printf %s "checking whether it is safe to define __EXTENSIONS__... " >&6; }-if test ${ac_cv_safe_to_define___extensions__+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#         define __EXTENSIONS__ 1-          $ac_includes_default-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_safe_to_define___extensions__=yes-else $as_nop-  ac_cv_safe_to_define___extensions__=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_safe_to_define___extensions__" >&5-printf "%s\n" "$ac_cv_safe_to_define___extensions__" >&6; }--  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether _XOPEN_SOURCE should be defined" >&5-printf %s "checking whether _XOPEN_SOURCE should be defined... " >&6; }-if test ${ac_cv_should_define__xopen_source+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_cv_should_define__xopen_source=no-    if test $ac_cv_header_wchar_h = yes-then :-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--          #include <wchar.h>-          mbstate_t x;-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :--else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--            #define _XOPEN_SOURCE 500-            #include <wchar.h>-            mbstate_t x;-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_should_define__xopen_source=yes-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_should_define__xopen_source" >&5-printf "%s\n" "$ac_cv_should_define__xopen_source" >&6; }--  printf "%s\n" "#define _ALL_SOURCE 1" >>confdefs.h--  printf "%s\n" "#define _DARWIN_C_SOURCE 1" >>confdefs.h--  printf "%s\n" "#define _GNU_SOURCE 1" >>confdefs.h--  printf "%s\n" "#define _HPUX_ALT_XOPEN_SOCKET_API 1" >>confdefs.h--  printf "%s\n" "#define _NETBSD_SOURCE 1" >>confdefs.h--  printf "%s\n" "#define _OPENBSD_SOURCE 1" >>confdefs.h--  printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_IEC_60559_BFP_EXT__ 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_IEC_60559_DFP_EXT__ 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_IEC_60559_TYPES_EXT__ 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_LIB_EXT2__ 1" >>confdefs.h--  printf "%s\n" "#define __STDC_WANT_MATH_SPEC_FUNCS__ 1" >>confdefs.h--  printf "%s\n" "#define _TANDEM_SOURCE 1" >>confdefs.h--  if test $ac_cv_header_minix_config_h = yes-then :-  MINIX=yes-    printf "%s\n" "#define _MINIX 1" >>confdefs.h--    printf "%s\n" "#define _POSIX_SOURCE 1" >>confdefs.h--    printf "%s\n" "#define _POSIX_1_SOURCE 2" >>confdefs.h--else $as_nop-  MINIX=-fi-  if test $ac_cv_safe_to_define___extensions__ = yes-then :-  printf "%s\n" "#define __EXTENSIONS__ 1" >>confdefs.h--fi-  if test $ac_cv_should_define__xopen_source = yes-then :-  printf "%s\n" "#define _XOPEN_SOURCE 500" >>confdefs.h--fi---{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for WINDOWS platform" >&5-printf %s "checking for WINDOWS platform... " >&6; }-case $host_alias in-    *mingw32*|*mingw64*|*cygwin*|*msys*)-        WINDOWS=YES;;-    *)-        WINDOWS=NO;;-esac-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $WINDOWS" >&5-printf "%s\n" "$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 :--printf "%s\n" "#define HAVE_LONG_LONG 1" >>confdefs.h---fi---# check for specific header (.h) files that we are interested in-ac_fn_c_check_header_compile "$LINENO" "ctype.h" "ac_cv_header_ctype_h" "$ac_includes_default"-if test "x$ac_cv_header_ctype_h" = xyes-then :-  printf "%s\n" "#define HAVE_CTYPE_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "errno.h" "ac_cv_header_errno_h" "$ac_includes_default"-if test "x$ac_cv_header_errno_h" = xyes-then :-  printf "%s\n" "#define HAVE_ERRNO_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "fcntl.h" "ac_cv_header_fcntl_h" "$ac_includes_default"-if test "x$ac_cv_header_fcntl_h" = xyes-then :-  printf "%s\n" "#define HAVE_FCNTL_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "inttypes.h" "ac_cv_header_inttypes_h" "$ac_includes_default"-if test "x$ac_cv_header_inttypes_h" = xyes-then :-  printf "%s\n" "#define HAVE_INTTYPES_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "limits.h" "ac_cv_header_limits_h" "$ac_includes_default"-if test "x$ac_cv_header_limits_h" = xyes-then :-  printf "%s\n" "#define HAVE_LIMITS_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "signal.h" "ac_cv_header_signal_h" "$ac_includes_default"-if test "x$ac_cv_header_signal_h" = xyes-then :-  printf "%s\n" "#define HAVE_SIGNAL_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/file.h" "ac_cv_header_sys_file_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_file_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_FILE_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/resource.h" "ac_cv_header_sys_resource_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_resource_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_RESOURCE_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/select.h" "ac_cv_header_sys_select_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_select_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_SELECT_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/stat.h" "ac_cv_header_sys_stat_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_stat_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_STAT_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/syscall.h" "ac_cv_header_sys_syscall_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_syscall_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_SYSCALL_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/time.h" "ac_cv_header_sys_time_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_time_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_TIME_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/timeb.h" "ac_cv_header_sys_timeb_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_timeb_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_TIMEB_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/timers.h" "ac_cv_header_sys_timers_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_timers_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_TIMERS_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/times.h" "ac_cv_header_sys_times_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_times_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_TIMES_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/types.h" "ac_cv_header_sys_types_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_types_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_TYPES_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/utsname.h" "ac_cv_header_sys_utsname_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_utsname_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_UTSNAME_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/wait.h" "ac_cv_header_sys_wait_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_wait_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_WAIT_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "termios.h" "ac_cv_header_termios_h" "$ac_includes_default"-if test "x$ac_cv_header_termios_h" = xyes-then :-  printf "%s\n" "#define HAVE_TERMIOS_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "time.h" "ac_cv_header_time_h" "$ac_includes_default"-if test "x$ac_cv_header_time_h" = xyes-then :-  printf "%s\n" "#define HAVE_TIME_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$ac_includes_default"-if test "x$ac_cv_header_unistd_h" = xyes-then :-  printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "utime.h" "ac_cv_header_utime_h" "$ac_includes_default"-if test "x$ac_cv_header_utime_h" = xyes-then :-  printf "%s\n" "#define HAVE_UTIME_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "windows.h" "ac_cv_header_windows_h" "$ac_includes_default"-if test "x$ac_cv_header_windows_h" = xyes-then :-  printf "%s\n" "#define HAVE_WINDOWS_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "winsock.h" "ac_cv_header_winsock_h" "$ac_includes_default"-if test "x$ac_cv_header_winsock_h" = xyes-then :-  printf "%s\n" "#define HAVE_WINSOCK_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "langinfo.h" "ac_cv_header_langinfo_h" "$ac_includes_default"-if test "x$ac_cv_header_langinfo_h" = xyes-then :-  printf "%s\n" "#define HAVE_LANGINFO_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "poll.h" "ac_cv_header_poll_h" "$ac_includes_default"-if test "x$ac_cv_header_poll_h" = xyes-then :-  printf "%s\n" "#define HAVE_POLL_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/epoll.h" "ac_cv_header_sys_epoll_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_epoll_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_EPOLL_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/event.h" "ac_cv_header_sys_event_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_event_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_EVENT_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_eventfd_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_EVENTFD_H 1" >>confdefs.h--fi-ac_fn_c_check_header_compile "$LINENO" "sys/socket.h" "ac_cv_header_sys_socket_h" "$ac_includes_default"-if test "x$ac_cv_header_sys_socket_h" = xyes-then :-  printf "%s\n" "#define HAVE_SYS_SOCKET_H 1" >>confdefs.h--fi---# Enable large file support. Do this before testing the types ino_t, off_t, and-# rlim_t, because it will affect the result of that test.-# Check whether --enable-largefile was given.-if test ${enable_largefile+y}-then :-  enableval=$enable_largefile;-fi--if test "$enable_largefile" != no; then--  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for special C compiler options needed for large files" >&5-printf %s "checking for special C compiler options needed for large files... " >&6; }-if test ${ac_cv_sys_largefile_CC+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_cv_sys_largefile_CC=no-     if test "$GCC" != yes; then-       ac_save_CC=$CC-       while :; do-	 # IRIX 6.2 and later do not support large files by default,-	 # so use the C compiler's -n32 option if that helps.-	 cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <sys/types.h>- /* Check that off_t can represent 2**63 - 1 correctly.-    We can't simply define LARGE_OFF_T to be 9223372036854775807,-    since some C++ compilers masquerading as C compilers-    incorrectly reject 9223372036854775807.  */-#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))-  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721-		       && LARGE_OFF_T % 2147483647 == 1)-		      ? 1 : -1];-int-main (void)-{--  ;-  return 0;-}-_ACEOF-	 if ac_fn_c_try_compile "$LINENO"-then :-  break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam-	 CC="$CC -n32"-	 if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_sys_largefile_CC=' -n32'; break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam-	 break-       done-       CC=$ac_save_CC-       rm -f conftest.$ac_ext-    fi-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_largefile_CC" >&5-printf "%s\n" "$ac_cv_sys_largefile_CC" >&6; }-  if test "$ac_cv_sys_largefile_CC" != no; then-    CC=$CC$ac_cv_sys_largefile_CC-  fi--  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for _FILE_OFFSET_BITS value needed for large files" >&5-printf %s "checking for _FILE_OFFSET_BITS value needed for large files... " >&6; }-if test ${ac_cv_sys_file_offset_bits+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  while :; do-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <sys/types.h>- /* Check that off_t can represent 2**63 - 1 correctly.-    We can't simply define LARGE_OFF_T to be 9223372036854775807,-    since some C++ compilers masquerading as C compilers-    incorrectly reject 9223372036854775807.  */-#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))-  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721-		       && LARGE_OFF_T % 2147483647 == 1)-		      ? 1 : -1];-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_sys_file_offset_bits=no; break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#define _FILE_OFFSET_BITS 64-#include <sys/types.h>- /* Check that off_t can represent 2**63 - 1 correctly.-    We can't simply define LARGE_OFF_T to be 9223372036854775807,-    since some C++ compilers masquerading as C compilers-    incorrectly reject 9223372036854775807.  */-#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))-  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721-		       && LARGE_OFF_T % 2147483647 == 1)-		      ? 1 : -1];-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_sys_file_offset_bits=64; break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  ac_cv_sys_file_offset_bits=unknown-  break-done-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_file_offset_bits" >&5-printf "%s\n" "$ac_cv_sys_file_offset_bits" >&6; }-case $ac_cv_sys_file_offset_bits in #(-  no | unknown) ;;-  *)-printf "%s\n" "#define _FILE_OFFSET_BITS $ac_cv_sys_file_offset_bits" >>confdefs.h-;;-esac-rm -rf conftest*-  if test $ac_cv_sys_file_offset_bits = unknown; then-    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for _LARGE_FILES value needed for large files" >&5-printf %s "checking for _LARGE_FILES value needed for large files... " >&6; }-if test ${ac_cv_sys_large_files+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  while :; do-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <sys/types.h>- /* Check that off_t can represent 2**63 - 1 correctly.-    We can't simply define LARGE_OFF_T to be 9223372036854775807,-    since some C++ compilers masquerading as C compilers-    incorrectly reject 9223372036854775807.  */-#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))-  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721-		       && LARGE_OFF_T % 2147483647 == 1)-		      ? 1 : -1];-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_sys_large_files=no; break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#define _LARGE_FILES 1-#include <sys/types.h>- /* Check that off_t can represent 2**63 - 1 correctly.-    We can't simply define LARGE_OFF_T to be 9223372036854775807,-    since some C++ compilers masquerading as C compilers-    incorrectly reject 9223372036854775807.  */-#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))-  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721-		       && LARGE_OFF_T % 2147483647 == 1)-		      ? 1 : -1];-int-main (void)-{--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  ac_cv_sys_large_files=1; break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-  ac_cv_sys_large_files=unknown-  break-done-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_large_files" >&5-printf "%s\n" "$ac_cv_sys_large_files" >&6; }-case $ac_cv_sys_large_files in #(-  no | unknown) ;;-  *)-printf "%s\n" "#define _LARGE_FILES $ac_cv_sys_large_files" >>confdefs.h-;;-esac-rm -rf conftest*-  fi-fi---       for ac_header in wctype.h-do :-  ac_fn_c_check_header_compile "$LINENO" "wctype.h" "ac_cv_header_wctype_h" "$ac_includes_default"-if test "x$ac_cv_header_wctype_h" = xyes-then :-  printf "%s\n" "#define HAVE_WCTYPE_H 1" >>confdefs.h- ac_fn_c_check_func "$LINENO" "iswspace" "ac_cv_func_iswspace"-if test "x$ac_cv_func_iswspace" = xyes-then :-  printf "%s\n" "#define HAVE_ISWSPACE 1" >>confdefs.h--fi--fi--done--ac_fn_c_check_func "$LINENO" "lstat" "ac_cv_func_lstat"-if test "x$ac_cv_func_lstat" = xyes-then :-  printf "%s\n" "#define HAVE_LSTAT 1" >>confdefs.h--fi--{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5-printf %s "checking for clock_gettime in -lrt... " >&6; }-if test ${ac_cv_lib_rt_clock_gettime+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_check_lib_save_LIBS=$LIBS-LIBS="-lrt  $LIBS"-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--/* Override any GCC internal prototype to avoid an error.-   Use char because int might match the return type of a GCC-   builtin and then its argument prototype would still apply.  */-char clock_gettime ();-int-main (void)-{-return clock_gettime ();-  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_link "$LINENO"-then :-  ac_cv_lib_rt_clock_gettime=yes-else $as_nop-  ac_cv_lib_rt_clock_gettime=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam \-    conftest$ac_exeext conftest.$ac_ext-LIBS=$ac_check_lib_save_LIBS-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rt_clock_gettime" >&5-printf "%s\n" "$ac_cv_lib_rt_clock_gettime" >&6; }-if test "x$ac_cv_lib_rt_clock_gettime" = xyes-then :-  printf "%s\n" "#define HAVE_LIBRT 1" >>confdefs.h--  LIBS="-lrt $LIBS"--fi--ac_fn_c_check_func "$LINENO" "clock_gettime" "ac_cv_func_clock_gettime"-if test "x$ac_cv_func_clock_gettime" = xyes-then :-  printf "%s\n" "#define HAVE_CLOCK_GETTIME 1" >>confdefs.h--fi--ac_fn_c_check_func "$LINENO" "getclock" "ac_cv_func_getclock"-if test "x$ac_cv_func_getclock" = xyes-then :-  printf "%s\n" "#define HAVE_GETCLOCK 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "getrusage" "ac_cv_func_getrusage"-if test "x$ac_cv_func_getrusage" = xyes-then :-  printf "%s\n" "#define HAVE_GETRUSAGE 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "times" "ac_cv_func_times"-if test "x$ac_cv_func_times" = xyes-then :-  printf "%s\n" "#define HAVE_TIMES 1" >>confdefs.h--fi--ac_fn_c_check_func "$LINENO" "_chsize" "ac_cv_func__chsize"-if test "x$ac_cv_func__chsize" = xyes-then :-  printf "%s\n" "#define HAVE__CHSIZE 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "ftruncate" "ac_cv_func_ftruncate"-if test "x$ac_cv_func_ftruncate" = xyes-then :-  printf "%s\n" "#define HAVE_FTRUNCATE 1" >>confdefs.h--fi---# event-related fun-# The line below already defines HAVE_KQUEUE and HAVE_POLL, so technically some of the-# subsequent portions that redefine them could be skipped. However, we keep those portions-# to keep kqueue/poll in line with HAVE_EPOLL and possible other additions in the future. You-# should be aware of this peculiarity if you try to simulate not having kqueue or poll by-# moving away header files (see also https://gitlab.haskell.org/ghc/ghc/-/issues/9283)-ac_fn_c_check_func "$LINENO" "epoll_ctl" "ac_cv_func_epoll_ctl"-if test "x$ac_cv_func_epoll_ctl" = xyes-then :-  printf "%s\n" "#define HAVE_EPOLL_CTL 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "eventfd" "ac_cv_func_eventfd"-if test "x$ac_cv_func_eventfd" = xyes-then :-  printf "%s\n" "#define HAVE_EVENTFD 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "kevent" "ac_cv_func_kevent"-if test "x$ac_cv_func_kevent" = xyes-then :-  printf "%s\n" "#define HAVE_KEVENT 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "kevent64" "ac_cv_func_kevent64"-if test "x$ac_cv_func_kevent64" = xyes-then :-  printf "%s\n" "#define HAVE_KEVENT64 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "kqueue" "ac_cv_func_kqueue"-if test "x$ac_cv_func_kqueue" = xyes-then :-  printf "%s\n" "#define HAVE_KQUEUE 1" >>confdefs.h--fi-ac_fn_c_check_func "$LINENO" "poll" "ac_cv_func_poll"-if test "x$ac_cv_func_poll" = xyes-then :-  printf "%s\n" "#define HAVE_POLL 1" >>confdefs.h--fi---if test "$ac_cv_header_sys_epoll_h" = yes && test "$ac_cv_func_epoll_ctl" = yes; then--printf "%s\n" "#define HAVE_EPOLL 1" >>confdefs.h--fi--if test "$ac_cv_header_sys_event_h" = yes && test "$ac_cv_func_kqueue" = yes; then--printf "%s\n" "#define HAVE_KQUEUE 1" >>confdefs.h---  # 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]];'.-# This bug is HP SR number 8606223364.-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of kev.filter" >&5-printf %s "checking size of kev.filter... " >&6; }-if test ${ac_cv_sizeof_kev_filter+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (kev.filter))" "ac_cv_sizeof_kev_filter"        "#include <sys/event.h>-struct kevent kev;-"-then :--else $as_nop-  if test "$ac_cv_type_kev_filter" = yes; then-     { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error 77 "cannot compute sizeof (kev.filter)-See \`config.log' for more details" "$LINENO" 5; }-   else-     ac_cv_sizeof_kev_filter=0-   fi-fi--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_kev_filter" >&5-printf "%s\n" "$ac_cv_sizeof_kev_filter" >&6; }----printf "%s\n" "#define SIZEOF_KEV_FILTER $ac_cv_sizeof_kev_filter" >>confdefs.h----  # 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]];'.-# This bug is HP SR number 8606223364.-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of kev.flags" >&5-printf %s "checking size of kev.flags... " >&6; }-if test ${ac_cv_sizeof_kev_flags+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (kev.flags))" "ac_cv_sizeof_kev_flags"        "#include <sys/event.h>-struct kevent kev;-"-then :--else $as_nop-  if test "$ac_cv_type_kev_flags" = yes; then-     { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error 77 "cannot compute sizeof (kev.flags)-See \`config.log' for more details" "$LINENO" 5; }-   else-     ac_cv_sizeof_kev_flags=0-   fi-fi--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_kev_flags" >&5-printf "%s\n" "$ac_cv_sizeof_kev_flags" >&6; }----printf "%s\n" "#define SIZEOF_KEV_FLAGS $ac_cv_sizeof_kev_flags" >>confdefs.h---fi--if test "$ac_cv_header_poll_h" = yes && test "$ac_cv_func_poll" = yes; then--printf "%s\n" "#define HAVE_POLL 1" >>confdefs.h--fi--# Linux open file descriptor locks-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC options needed to detect all undeclared functions" >&5-printf %s "checking for $CC options needed to detect all undeclared functions... " >&6; }-if test ${ac_cv_c_undeclared_builtin_options+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_save_CFLAGS=$CFLAGS-   ac_cv_c_undeclared_builtin_options='cannot detect'-   for ac_arg in '' -fno-builtin; do-     CFLAGS="$ac_save_CFLAGS $ac_arg"-     # This test program should *not* compile successfully.-     cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--int-main (void)-{-(void) strchr;-  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :--else $as_nop-  # This test program should compile successfully.-        # No library function is consistently available on-        # freestanding implementations, so test against a dummy-        # declaration.  Include always-available headers on the-        # off chance that they somehow elicit warnings.-        cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <float.h>-#include <limits.h>-#include <stdarg.h>-#include <stddef.h>-extern void ac_decl (int, char *);--int-main (void)-{-(void) ac_decl (0, (char *) 0);-  (void) ac_decl;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  if test x"$ac_arg" = x-then :-  ac_cv_c_undeclared_builtin_options='none needed'-else $as_nop-  ac_cv_c_undeclared_builtin_options=$ac_arg-fi-          break-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext-    done-    CFLAGS=$ac_save_CFLAGS--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5-printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; }-  case $ac_cv_c_undeclared_builtin_options in #(-  'cannot detect') :-    { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "cannot make $CC report undeclared builtins-See \`config.log' for more details" "$LINENO" 5; } ;; #(-  'none needed') :-    ac_c_undeclared_builtin_options='' ;; #(-  *) :-    ac_c_undeclared_builtin_options=$ac_cv_c_undeclared_builtin_options ;;-esac--ac_fn_check_decl "$LINENO" "F_OFD_SETLK" "ac_cv_have_decl_F_OFD_SETLK" "-  #include <unistd.h>-  #include <fcntl.h>--" "$ac_c_undeclared_builtin_options" "CFLAGS"-if test "x$ac_cv_have_decl_F_OFD_SETLK" = xyes-then :---printf "%s\n" "#define HAVE_OFD_LOCKING 1" >>confdefs.h---fi--# flock-ac_fn_c_check_func "$LINENO" "flock" "ac_cv_func_flock"-if test "x$ac_cv_func_flock" = xyes-then :-  printf "%s\n" "#define HAVE_FLOCK 1" >>confdefs.h--fi--if test "$ac_cv_header_sys_file_h" = yes && test "$ac_cv_func_flock" = yes; then--printf "%s\n" "#define HAVE_FLOCK 1" >>confdefs.h--fi--# unsetenv-ac_fn_c_check_func "$LINENO" "unsetenv" "ac_cv_func_unsetenv"-if test "x$ac_cv_func_unsetenv" = xyes-then :-  printf "%s\n" "#define HAVE_UNSETENV 1" >>confdefs.h--fi---###  POSIX.1003.1 unsetenv returns 0 or -1 (EINVAL), but older implementations-###  in common use return void.-ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5-printf %s "checking how to run the C preprocessor... " >&6; }-# On Suns, sometimes $CPP names a directory.-if test -n "$CPP" && test -d "$CPP"; then-  CPP=-fi-if test -z "$CPP"; then-  if test ${ac_cv_prog_CPP+y}-then :-  printf %s "(cached) " >&6-else $as_nop-      # Double quotes because $CC needs to be expanded-    for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp-    do-      ac_preproc_ok=false-for ac_c_preproc_warn_flag in '' yes-do-  # Use a header file that comes with gcc, so configuring glibc-  # with a fresh cross-compiler works.-  # On the NeXT, cc -E runs the code through the compiler's parser,-  # not just through cpp. "Syntax error" is here to catch this case.-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <limits.h>-		     Syntax error-_ACEOF-if ac_fn_c_try_cpp "$LINENO"-then :--else $as_nop-  # Broken: fails on valid input.-continue-fi-rm -f conftest.err conftest.i conftest.$ac_ext--  # OK, works on sane cases.  Now check whether nonexistent headers-  # can be detected and how.-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <ac_nonexistent.h>-_ACEOF-if ac_fn_c_try_cpp "$LINENO"-then :-  # Broken: success on invalid input.-continue-else $as_nop-  # Passes both tests.-ac_preproc_ok=:-break-fi-rm -f conftest.err conftest.i conftest.$ac_ext--done-# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.-rm -f conftest.i conftest.err conftest.$ac_ext-if $ac_preproc_ok-then :-  break-fi--    done-    ac_cv_prog_CPP=$CPP--fi-  CPP=$ac_cv_prog_CPP-else-  ac_cv_prog_CPP=$CPP-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5-printf "%s\n" "$CPP" >&6; }-ac_preproc_ok=false-for ac_c_preproc_warn_flag in '' yes-do-  # Use a header file that comes with gcc, so configuring glibc-  # with a fresh cross-compiler works.-  # On the NeXT, cc -E runs the code through the compiler's parser,-  # not just through cpp. "Syntax error" is here to catch this case.-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <limits.h>-		     Syntax error-_ACEOF-if ac_fn_c_try_cpp "$LINENO"-then :--else $as_nop-  # Broken: fails on valid input.-continue-fi-rm -f conftest.err conftest.i conftest.$ac_ext--  # OK, works on sane cases.  Now check whether nonexistent headers-  # can be detected and how.-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <ac_nonexistent.h>-_ACEOF-if ac_fn_c_try_cpp "$LINENO"-then :-  # Broken: success on invalid input.-continue-else $as_nop-  # Passes both tests.-ac_preproc_ok=:-break-fi-rm -f conftest.err conftest.i conftest.$ac_ext--done-# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.-rm -f conftest.i conftest.err conftest.$ac_ext-if $ac_preproc_ok-then :--else $as_nop-  { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error $? "C preprocessor \"$CPP\" fails sanity check-See \`config.log' for more details" "$LINENO" 5; }-fi--ac_ext=c-ac_cpp='$CPP $CPPFLAGS'-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'-ac_compiler_gnu=$ac_cv_c_compiler_gnu---{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5-printf %s "checking for grep that handles long lines and -e... " >&6; }-if test ${ac_cv_path_GREP+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if test -z "$GREP"; then-  ac_path_GREP_found=false-  # Loop through the user's path and test for each of PROGNAME-LIST-  as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_prog in grep ggrep-   do-    for ac_exec_ext in '' $ac_executable_extensions; do-      ac_path_GREP="$as_dir$ac_prog$ac_exec_ext"-      as_fn_executable_p "$ac_path_GREP" || continue-# Check for GNU ac_path_GREP and select it if it is found.-  # Check for GNU $ac_path_GREP-case `"$ac_path_GREP" --version 2>&1` in-*GNU*)-  ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;-*)-  ac_count=0-  printf %s 0123456789 >"conftest.in"-  while :-  do-    cat "conftest.in" "conftest.in" >"conftest.tmp"-    mv "conftest.tmp" "conftest.in"-    cp "conftest.in" "conftest.nl"-    printf "%s\n" 'GREP' >> "conftest.nl"-    "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break-    diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break-    as_fn_arith $ac_count + 1 && ac_count=$as_val-    if test $ac_count -gt ${ac_path_GREP_max-0}; then-      # Best one so far, save it but keep looking for a better one-      ac_cv_path_GREP="$ac_path_GREP"-      ac_path_GREP_max=$ac_count-    fi-    # 10*(2^10) chars as input seems more than enough-    test $ac_count -gt 10 && break-  done-  rm -f conftest.in conftest.tmp conftest.nl conftest.out;;-esac--      $ac_path_GREP_found && break 3-    done-  done-  done-IFS=$as_save_IFS-  if test -z "$ac_cv_path_GREP"; then-    as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5-  fi-else-  ac_cv_path_GREP=$GREP-fi--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5-printf "%s\n" "$ac_cv_path_GREP" >&6; }- GREP="$ac_cv_path_GREP"---{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5-printf %s "checking for egrep... " >&6; }-if test ${ac_cv_path_EGREP+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if echo a | $GREP -E '(a|b)' >/dev/null 2>&1-   then ac_cv_path_EGREP="$GREP -E"-   else-     if test -z "$EGREP"; then-  ac_path_EGREP_found=false-  # Loop through the user's path and test for each of PROGNAME-LIST-  as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    for ac_prog in egrep-   do-    for ac_exec_ext in '' $ac_executable_extensions; do-      ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext"-      as_fn_executable_p "$ac_path_EGREP" || continue-# Check for GNU ac_path_EGREP and select it if it is found.-  # Check for GNU $ac_path_EGREP-case `"$ac_path_EGREP" --version 2>&1` in-*GNU*)-  ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;-*)-  ac_count=0-  printf %s 0123456789 >"conftest.in"-  while :-  do-    cat "conftest.in" "conftest.in" >"conftest.tmp"-    mv "conftest.tmp" "conftest.in"-    cp "conftest.in" "conftest.nl"-    printf "%s\n" 'EGREP' >> "conftest.nl"-    "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break-    diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break-    as_fn_arith $ac_count + 1 && ac_count=$as_val-    if test $ac_count -gt ${ac_path_EGREP_max-0}; then-      # Best one so far, save it but keep looking for a better one-      ac_cv_path_EGREP="$ac_path_EGREP"-      ac_path_EGREP_max=$ac_count-    fi-    # 10*(2^10) chars as input seems more than enough-    test $ac_count -gt 10 && break-  done-  rm -f conftest.in conftest.tmp conftest.nl conftest.out;;-esac--      $ac_path_EGREP_found && break 3-    done-  done-  done-IFS=$as_save_IFS-  if test -z "$ac_cv_path_EGREP"; then-    as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5-  fi-else-  ac_cv_path_EGREP=$EGREP-fi--   fi-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5-printf "%s\n" "$ac_cv_path_EGREP" >&6; }- EGREP="$ac_cv_path_EGREP"---{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking return type of unsetenv" >&5-printf %s "checking return type of unsetenv... " >&6; }-if test ${fptools_cv_func_unsetenv_return_type+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <stdlib.h>--_ACEOF-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |-  $EGREP "void[      ]+unsetenv" >/dev/null 2>&1-then :-  fptools_cv_func_unsetenv_return_type=void-else $as_nop-  fptools_cv_func_unsetenv_return_type=int-fi-rm -rf conftest*--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_func_unsetenv_return_type" >&5-printf "%s\n" "$fptools_cv_func_unsetenv_return_type" >&6; }-case "$fptools_cv_func_unsetenv_return_type" in-  "void" )--printf "%s\n" "#define UNSETENV_RETURNS_VOID 1" >>confdefs.h--  ;;-esac----# Check whether --with-iconv-includes was given.-if test ${with_iconv_includes+y}-then :-  withval=$with_iconv_includes; ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval $CPPFLAGS"-else $as_nop-  ICONV_INCLUDE_DIRS=-fi----# Check whether --with-iconv-libraries was given.-if test ${with_iconv_libraries+y}-then :-  withval=$with_iconv_libraries; ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval $LDFLAGS"-else $as_nop-  ICONV_LIB_DIRS=-fi------# map standard C types and ISO types to Haskell types---------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for char" >&5-printf %s "checking Haskell type for char... " >&6; }-    if test ${fptools_cv_htype_char+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_char=yes-        if ac_fn_c_compute_int "$LINENO" "(char)0.2 - (char)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-char val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_char="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(char) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_char=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(char) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_char=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(char) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_char=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_char=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_char=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_char=LDouble-                else-                    fptools_cv_htype_sup_char=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((char)(-1)) < ((char)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_char=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(char) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_char=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_char="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_char="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_char" = no-    then--        fptools_cv_htype_char=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_char" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_char" >&5-printf "%s\n" "$fptools_cv_htype_char" >&6; }--printf "%s\n" "#define HTYPE_CHAR $fptools_cv_htype_char" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for signed char" >&5-printf %s "checking Haskell type for signed char... " >&6; }-    if test ${fptools_cv_htype_signed_char+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_signed_char=yes-        if ac_fn_c_compute_int "$LINENO" "(signed char)0.2 - (signed char)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-signed char val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_signed_char="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(signed char) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_signed_char=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(signed char) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_signed_char=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(signed char) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_signed_char=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_signed_char=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_signed_char=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_signed_char=LDouble-                else-                    fptools_cv_htype_sup_signed_char=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((signed char)(-1)) < ((signed char)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_signed_char=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(signed char) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_signed_char=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_signed_char="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_signed_char="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_signed_char" = no-    then--        fptools_cv_htype_signed_char=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_signed_char" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_signed_char" >&5-printf "%s\n" "$fptools_cv_htype_signed_char" >&6; }--printf "%s\n" "#define HTYPE_SIGNED_CHAR $fptools_cv_htype_signed_char" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned char" >&5-printf %s "checking Haskell type for unsigned char... " >&6; }-    if test ${fptools_cv_htype_unsigned_char+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_unsigned_char=yes-        if ac_fn_c_compute_int "$LINENO" "(unsigned char)0.2 - (unsigned char)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-unsigned char val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_unsigned_char="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned char) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_char=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned char) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_char=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned char) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_char=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_unsigned_char=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_char=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_char=LDouble-                else-                    fptools_cv_htype_sup_unsigned_char=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((unsigned char)(-1)) < ((unsigned char)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_char=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned char) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_char=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_unsigned_char="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_unsigned_char="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_unsigned_char" = no-    then--        fptools_cv_htype_unsigned_char=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_unsigned_char" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_unsigned_char" >&5-printf "%s\n" "$fptools_cv_htype_unsigned_char" >&6; }--printf "%s\n" "#define HTYPE_UNSIGNED_CHAR $fptools_cv_htype_unsigned_char" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for short" >&5-printf %s "checking Haskell type for short... " >&6; }-    if test ${fptools_cv_htype_short+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_short=yes-        if ac_fn_c_compute_int "$LINENO" "(short)0.2 - (short)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-short val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_short="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(short) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_short=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(short) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_short=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(short) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_short=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_short=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_short=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_short=LDouble-                else-                    fptools_cv_htype_sup_short=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((short)(-1)) < ((short)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_short=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(short) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_short=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_short="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_short="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_short" = no-    then--        fptools_cv_htype_short=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_short" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_short" >&5-printf "%s\n" "$fptools_cv_htype_short" >&6; }--printf "%s\n" "#define HTYPE_SHORT $fptools_cv_htype_short" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned short" >&5-printf %s "checking Haskell type for unsigned short... " >&6; }-    if test ${fptools_cv_htype_unsigned_short+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_unsigned_short=yes-        if ac_fn_c_compute_int "$LINENO" "(unsigned short)0.2 - (unsigned short)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-unsigned short val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_unsigned_short="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned short) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_short=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned short) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_short=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned short) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_short=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_unsigned_short=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_short=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_short=LDouble-                else-                    fptools_cv_htype_sup_unsigned_short=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((unsigned short)(-1)) < ((unsigned short)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_short=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned short) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_short=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_unsigned_short="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_unsigned_short="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_unsigned_short" = no-    then--        fptools_cv_htype_unsigned_short=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_unsigned_short" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_unsigned_short" >&5-printf "%s\n" "$fptools_cv_htype_unsigned_short" >&6; }--printf "%s\n" "#define HTYPE_UNSIGNED_SHORT $fptools_cv_htype_unsigned_short" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for int" >&5-printf %s "checking Haskell type for int... " >&6; }-    if test ${fptools_cv_htype_int+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_int=yes-        if ac_fn_c_compute_int "$LINENO" "(int)0.2 - (int)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-int val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_int="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(int) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_int=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(int) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_int=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(int) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_int=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_int=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_int=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_int=LDouble-                else-                    fptools_cv_htype_sup_int=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((int)(-1)) < ((int)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_int=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(int) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_int=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_int="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_int="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_int" = no-    then--        fptools_cv_htype_int=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_int" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_int" >&5-printf "%s\n" "$fptools_cv_htype_int" >&6; }--printf "%s\n" "#define HTYPE_INT $fptools_cv_htype_int" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned int" >&5-printf %s "checking Haskell type for unsigned int... " >&6; }-    if test ${fptools_cv_htype_unsigned_int+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_unsigned_int=yes-        if ac_fn_c_compute_int "$LINENO" "(unsigned int)0.2 - (unsigned int)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-unsigned int val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_unsigned_int="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned int) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_int=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned int) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_int=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned int) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_int=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_unsigned_int=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_int=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_int=LDouble-                else-                    fptools_cv_htype_sup_unsigned_int=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((unsigned int)(-1)) < ((unsigned int)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_int=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned int) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_int=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_unsigned_int="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_unsigned_int="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_unsigned_int" = no-    then--        fptools_cv_htype_unsigned_int=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_unsigned_int" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_unsigned_int" >&5-printf "%s\n" "$fptools_cv_htype_unsigned_int" >&6; }--printf "%s\n" "#define HTYPE_UNSIGNED_INT $fptools_cv_htype_unsigned_int" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for long" >&5-printf %s "checking Haskell type for long... " >&6; }-    if test ${fptools_cv_htype_long+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_long=yes-        if ac_fn_c_compute_int "$LINENO" "(long)0.2 - (long)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-long val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_long="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(long) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(long) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(long) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_long=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_long=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_long=LDouble-                else-                    fptools_cv_htype_sup_long=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((long)(-1)) < ((long)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(long) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_long="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_long="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_long" = no-    then--        fptools_cv_htype_long=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_long" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_long" >&5-printf "%s\n" "$fptools_cv_htype_long" >&6; }--printf "%s\n" "#define HTYPE_LONG $fptools_cv_htype_long" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned long" >&5-printf %s "checking Haskell type for unsigned long... " >&6; }-    if test ${fptools_cv_htype_unsigned_long+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_unsigned_long=yes-        if ac_fn_c_compute_int "$LINENO" "(unsigned long)0.2 - (unsigned long)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-unsigned long val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_unsigned_long="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_unsigned_long=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_long=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_long=LDouble-                else-                    fptools_cv_htype_sup_unsigned_long=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((unsigned long)(-1)) < ((unsigned long)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_unsigned_long="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_unsigned_long="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_unsigned_long" = no-    then--        fptools_cv_htype_unsigned_long=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_unsigned_long" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_unsigned_long" >&5-printf "%s\n" "$fptools_cv_htype_unsigned_long" >&6; }--printf "%s\n" "#define HTYPE_UNSIGNED_LONG $fptools_cv_htype_unsigned_long" >>confdefs.h--    fi---if test "$ac_cv_type_long_long" = yes; then---------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for long long" >&5-printf %s "checking Haskell type for long long... " >&6; }-    if test ${fptools_cv_htype_long_long+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_long_long=yes-        if ac_fn_c_compute_int "$LINENO" "(long long)0.2 - (long long)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-long long val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_long_long="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(long long) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(long long) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(long long) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long_long=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_long_long=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_long_long=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_long_long=LDouble-                else-                    fptools_cv_htype_sup_long_long=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((long long)(-1)) < ((long long)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long_long=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(long long) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_long_long=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_long_long="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_long_long="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_long_long" = no-    then--        fptools_cv_htype_long_long=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_long_long" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_long_long" >&5-printf "%s\n" "$fptools_cv_htype_long_long" >&6; }--printf "%s\n" "#define HTYPE_LONG_LONG $fptools_cv_htype_long_long" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for unsigned long long" >&5-printf %s "checking Haskell type for unsigned long long... " >&6; }-    if test ${fptools_cv_htype_unsigned_long_long+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_unsigned_long_long=yes-        if ac_fn_c_compute_int "$LINENO" "(unsigned long long)0.2 - (unsigned long long)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-unsigned long long val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_unsigned_long_long="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long long) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long long) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long_long=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long long) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long_long=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_unsigned_long_long=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_long_long=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_unsigned_long_long=LDouble-                else-                    fptools_cv_htype_sup_unsigned_long_long=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((unsigned long long)(-1)) < ((unsigned long long)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long_long=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(unsigned long long) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_unsigned_long_long=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_unsigned_long_long="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_unsigned_long_long="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_unsigned_long_long" = no-    then--        fptools_cv_htype_unsigned_long_long=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_unsigned_long_long" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_unsigned_long_long" >&5-printf "%s\n" "$fptools_cv_htype_unsigned_long_long" >&6; }--printf "%s\n" "#define HTYPE_UNSIGNED_LONG_LONG $fptools_cv_htype_unsigned_long_long" >>confdefs.h--    fi---fi---------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for bool" >&5-printf %s "checking Haskell type for bool... " >&6; }-    if test ${fptools_cv_htype_bool+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_bool=yes-        if ac_fn_c_compute_int "$LINENO" "(bool)0.2 - (bool)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-bool val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_bool="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(bool) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_bool=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(bool) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_bool=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(bool) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_bool=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_bool=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_bool=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_bool=LDouble-                else-                    fptools_cv_htype_sup_bool=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((bool)(-1)) < ((bool)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_bool=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(bool) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_bool=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_bool="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_bool="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_bool" = no-    then--        fptools_cv_htype_bool=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_bool" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_bool" >&5-printf "%s\n" "$fptools_cv_htype_bool" >&6; }--printf "%s\n" "#define HTYPE_BOOL $fptools_cv_htype_bool" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for float" >&5-printf %s "checking Haskell type for float... " >&6; }-    if test ${fptools_cv_htype_float+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_float=yes-        if ac_fn_c_compute_int "$LINENO" "(float)0.2 - (float)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-float val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_float="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(float) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_float=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(float) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_float=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(float) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_float=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_float=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_float=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_float=LDouble-                else-                    fptools_cv_htype_sup_float=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((float)(-1)) < ((float)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_float=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(float) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_float=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_float="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_float="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_float" = no-    then--        fptools_cv_htype_float=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_float" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_float" >&5-printf "%s\n" "$fptools_cv_htype_float" >&6; }--printf "%s\n" "#define HTYPE_FLOAT $fptools_cv_htype_float" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for double" >&5-printf %s "checking Haskell type for double... " >&6; }-    if test ${fptools_cv_htype_double+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_double=yes-        if ac_fn_c_compute_int "$LINENO" "(double)0.2 - (double)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-double val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_double="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(double) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_double=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(double) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_double=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(double) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_double=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_double=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_double=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_double=LDouble-                else-                    fptools_cv_htype_sup_double=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((double)(-1)) < ((double)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_double=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(double) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_double=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_double="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_double="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_double" = no-    then--        fptools_cv_htype_double=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_double" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_double" >&5-printf "%s\n" "$fptools_cv_htype_double" >&6; }--printf "%s\n" "#define HTYPE_DOUBLE $fptools_cv_htype_double" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for ptrdiff_t" >&5-printf %s "checking Haskell type for ptrdiff_t... " >&6; }-    if test ${fptools_cv_htype_ptrdiff_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_ptrdiff_t=yes-        if ac_fn_c_compute_int "$LINENO" "(ptrdiff_t)0.2 - (ptrdiff_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-ptrdiff_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_ptrdiff_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(ptrdiff_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ptrdiff_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(ptrdiff_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ptrdiff_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(ptrdiff_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ptrdiff_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_ptrdiff_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_ptrdiff_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_ptrdiff_t=LDouble-                else-                    fptools_cv_htype_sup_ptrdiff_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((ptrdiff_t)(-1)) < ((ptrdiff_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ptrdiff_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(ptrdiff_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ptrdiff_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_ptrdiff_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_ptrdiff_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_ptrdiff_t" = no-    then--        fptools_cv_htype_ptrdiff_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_ptrdiff_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_ptrdiff_t" >&5-printf "%s\n" "$fptools_cv_htype_ptrdiff_t" >&6; }--printf "%s\n" "#define HTYPE_PTRDIFF_T $fptools_cv_htype_ptrdiff_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for size_t" >&5-printf %s "checking Haskell type for size_t... " >&6; }-    if test ${fptools_cv_htype_size_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_size_t=yes-        if ac_fn_c_compute_int "$LINENO" "(size_t)0.2 - (size_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-size_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_size_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(size_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_size_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(size_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_size_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(size_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_size_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_size_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_size_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_size_t=LDouble-                else-                    fptools_cv_htype_sup_size_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((size_t)(-1)) < ((size_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_size_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(size_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_size_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_size_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_size_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_size_t" = no-    then--        fptools_cv_htype_size_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_size_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_size_t" >&5-printf "%s\n" "$fptools_cv_htype_size_t" >&6; }--printf "%s\n" "#define HTYPE_SIZE_T $fptools_cv_htype_size_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for wchar_t" >&5-printf %s "checking Haskell type for wchar_t... " >&6; }-    if test ${fptools_cv_htype_wchar_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_wchar_t=yes-        if ac_fn_c_compute_int "$LINENO" "(wchar_t)0.2 - (wchar_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-wchar_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_wchar_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(wchar_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_wchar_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(wchar_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_wchar_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(wchar_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_wchar_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_wchar_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_wchar_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_wchar_t=LDouble-                else-                    fptools_cv_htype_sup_wchar_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((wchar_t)(-1)) < ((wchar_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_wchar_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(wchar_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_wchar_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_wchar_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_wchar_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_wchar_t" = no-    then--        fptools_cv_htype_wchar_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_wchar_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_wchar_t" >&5-printf "%s\n" "$fptools_cv_htype_wchar_t" >&6; }--printf "%s\n" "#define HTYPE_WCHAR_T $fptools_cv_htype_wchar_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for sig_atomic_t" >&5-printf %s "checking Haskell type for sig_atomic_t... " >&6; }-    if test ${fptools_cv_htype_sig_atomic_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_sig_atomic_t=yes-        if ac_fn_c_compute_int "$LINENO" "(sig_atomic_t)0.2 - (sig_atomic_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-sig_atomic_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_sig_atomic_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(sig_atomic_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_sig_atomic_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(sig_atomic_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_sig_atomic_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(sig_atomic_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_sig_atomic_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_sig_atomic_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_sig_atomic_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_sig_atomic_t=LDouble-                else-                    fptools_cv_htype_sup_sig_atomic_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((sig_atomic_t)(-1)) < ((sig_atomic_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_sig_atomic_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(sig_atomic_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_sig_atomic_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_sig_atomic_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_sig_atomic_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_sig_atomic_t" = no-    then--        fptools_cv_htype_sig_atomic_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_sig_atomic_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_sig_atomic_t" >&5-printf "%s\n" "$fptools_cv_htype_sig_atomic_t" >&6; }--printf "%s\n" "#define HTYPE_SIG_ATOMIC_T $fptools_cv_htype_sig_atomic_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for clock_t" >&5-printf %s "checking Haskell type for clock_t... " >&6; }-    if test ${fptools_cv_htype_clock_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_clock_t=yes-        if ac_fn_c_compute_int "$LINENO" "(clock_t)0.2 - (clock_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-clock_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_clock_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(clock_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clock_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(clock_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clock_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(clock_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clock_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_clock_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_clock_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_clock_t=LDouble-                else-                    fptools_cv_htype_sup_clock_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((clock_t)(-1)) < ((clock_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clock_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(clock_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clock_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_clock_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_clock_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_clock_t" = no-    then--        fptools_cv_htype_clock_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_clock_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_clock_t" >&5-printf "%s\n" "$fptools_cv_htype_clock_t" >&6; }--printf "%s\n" "#define HTYPE_CLOCK_T $fptools_cv_htype_clock_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for time_t" >&5-printf %s "checking Haskell type for time_t... " >&6; }-    if test ${fptools_cv_htype_time_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_time_t=yes-        if ac_fn_c_compute_int "$LINENO" "(time_t)0.2 - (time_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-time_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_time_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(time_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_time_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(time_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_time_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(time_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_time_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_time_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_time_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_time_t=LDouble-                else-                    fptools_cv_htype_sup_time_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((time_t)(-1)) < ((time_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_time_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(time_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_time_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_time_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_time_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_time_t" = no-    then--        fptools_cv_htype_time_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_time_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_time_t" >&5-printf "%s\n" "$fptools_cv_htype_time_t" >&6; }--printf "%s\n" "#define HTYPE_TIME_T $fptools_cv_htype_time_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for useconds_t" >&5-printf %s "checking Haskell type for useconds_t... " >&6; }-    if test ${fptools_cv_htype_useconds_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_useconds_t=yes-        if ac_fn_c_compute_int "$LINENO" "(useconds_t)0.2 - (useconds_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-useconds_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_useconds_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(useconds_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_useconds_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(useconds_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_useconds_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(useconds_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_useconds_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_useconds_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_useconds_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_useconds_t=LDouble-                else-                    fptools_cv_htype_sup_useconds_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((useconds_t)(-1)) < ((useconds_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_useconds_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(useconds_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_useconds_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_useconds_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_useconds_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_useconds_t" = no-    then--        fptools_cv_htype_useconds_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_useconds_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_useconds_t" >&5-printf "%s\n" "$fptools_cv_htype_useconds_t" >&6; }--printf "%s\n" "#define HTYPE_USECONDS_T $fptools_cv_htype_useconds_t" >>confdefs.h--    fi----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for suseconds_t" >&5-printf %s "checking Haskell type for suseconds_t... " >&6; }-    if test ${fptools_cv_htype_suseconds_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_suseconds_t=yes-        if ac_fn_c_compute_int "$LINENO" "(suseconds_t)0.2 - (suseconds_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-suseconds_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_suseconds_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(suseconds_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_suseconds_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(suseconds_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_suseconds_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(suseconds_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_suseconds_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_suseconds_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_suseconds_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_suseconds_t=LDouble-                else-                    fptools_cv_htype_sup_suseconds_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((suseconds_t)(-1)) < ((suseconds_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_suseconds_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(suseconds_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_suseconds_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_suseconds_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_suseconds_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_suseconds_t" = no-    then-        if test "$WINDOWS" = "YES"-                          then-                              fptools_cv_htype_suseconds_t=Int32-                              fptools_cv_htype_sup_suseconds_t=yes-                          else-                              as_fn_error $? "type not found" "$LINENO" 5-                          fi-    fi--            if test "$fptools_cv_htype_sup_suseconds_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_suseconds_t" >&5-printf "%s\n" "$fptools_cv_htype_suseconds_t" >&6; }--printf "%s\n" "#define HTYPE_SUSECONDS_T $fptools_cv_htype_suseconds_t" >>confdefs.h--    fi----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for dev_t" >&5-printf %s "checking Haskell type for dev_t... " >&6; }-    if test ${fptools_cv_htype_dev_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_dev_t=yes-        if ac_fn_c_compute_int "$LINENO" "(dev_t)0.2 - (dev_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-dev_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_dev_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(dev_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_dev_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(dev_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_dev_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(dev_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_dev_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_dev_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_dev_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_dev_t=LDouble-                else-                    fptools_cv_htype_sup_dev_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((dev_t)(-1)) < ((dev_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_dev_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(dev_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_dev_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_dev_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_dev_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_dev_t" = no-    then--        fptools_cv_htype_dev_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_dev_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_dev_t" >&5-printf "%s\n" "$fptools_cv_htype_dev_t" >&6; }--printf "%s\n" "#define HTYPE_DEV_T $fptools_cv_htype_dev_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for ino_t" >&5-printf %s "checking Haskell type for ino_t... " >&6; }-    if test ${fptools_cv_htype_ino_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_ino_t=yes-        if ac_fn_c_compute_int "$LINENO" "(ino_t)0.2 - (ino_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-ino_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_ino_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(ino_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ino_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(ino_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ino_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(ino_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ino_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_ino_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_ino_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_ino_t=LDouble-                else-                    fptools_cv_htype_sup_ino_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((ino_t)(-1)) < ((ino_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ino_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(ino_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ino_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_ino_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_ino_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_ino_t" = no-    then--        fptools_cv_htype_ino_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_ino_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_ino_t" >&5-printf "%s\n" "$fptools_cv_htype_ino_t" >&6; }--printf "%s\n" "#define HTYPE_INO_T $fptools_cv_htype_ino_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for mode_t" >&5-printf %s "checking Haskell type for mode_t... " >&6; }-    if test ${fptools_cv_htype_mode_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_mode_t=yes-        if ac_fn_c_compute_int "$LINENO" "(mode_t)0.2 - (mode_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-mode_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_mode_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(mode_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_mode_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(mode_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_mode_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(mode_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_mode_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_mode_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_mode_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_mode_t=LDouble-                else-                    fptools_cv_htype_sup_mode_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((mode_t)(-1)) < ((mode_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_mode_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(mode_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_mode_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_mode_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_mode_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_mode_t" = no-    then--        fptools_cv_htype_mode_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_mode_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_mode_t" >&5-printf "%s\n" "$fptools_cv_htype_mode_t" >&6; }--printf "%s\n" "#define HTYPE_MODE_T $fptools_cv_htype_mode_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for off_t" >&5-printf %s "checking Haskell type for off_t... " >&6; }-    if test ${fptools_cv_htype_off_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_off_t=yes-        if ac_fn_c_compute_int "$LINENO" "(off_t)0.2 - (off_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-off_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_off_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(off_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_off_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(off_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_off_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(off_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_off_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_off_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_off_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_off_t=LDouble-                else-                    fptools_cv_htype_sup_off_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((off_t)(-1)) < ((off_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_off_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(off_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_off_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_off_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_off_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_off_t" = no-    then--        fptools_cv_htype_off_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_off_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_off_t" >&5-printf "%s\n" "$fptools_cv_htype_off_t" >&6; }--printf "%s\n" "#define HTYPE_OFF_T $fptools_cv_htype_off_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for pid_t" >&5-printf %s "checking Haskell type for pid_t... " >&6; }-    if test ${fptools_cv_htype_pid_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_pid_t=yes-        if ac_fn_c_compute_int "$LINENO" "(pid_t)0.2 - (pid_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-pid_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_pid_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(pid_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_pid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(pid_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_pid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(pid_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_pid_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_pid_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_pid_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_pid_t=LDouble-                else-                    fptools_cv_htype_sup_pid_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((pid_t)(-1)) < ((pid_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_pid_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(pid_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_pid_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_pid_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_pid_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_pid_t" = no-    then--        fptools_cv_htype_pid_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_pid_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_pid_t" >&5-printf "%s\n" "$fptools_cv_htype_pid_t" >&6; }--printf "%s\n" "#define HTYPE_PID_T $fptools_cv_htype_pid_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for gid_t" >&5-printf %s "checking Haskell type for gid_t... " >&6; }-    if test ${fptools_cv_htype_gid_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_gid_t=yes-        if ac_fn_c_compute_int "$LINENO" "(gid_t)0.2 - (gid_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-gid_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_gid_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(gid_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_gid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(gid_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_gid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(gid_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_gid_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_gid_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_gid_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_gid_t=LDouble-                else-                    fptools_cv_htype_sup_gid_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((gid_t)(-1)) < ((gid_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_gid_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(gid_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_gid_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_gid_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_gid_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_gid_t" = no-    then--        fptools_cv_htype_gid_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_gid_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_gid_t" >&5-printf "%s\n" "$fptools_cv_htype_gid_t" >&6; }--printf "%s\n" "#define HTYPE_GID_T $fptools_cv_htype_gid_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for uid_t" >&5-printf %s "checking Haskell type for uid_t... " >&6; }-    if test ${fptools_cv_htype_uid_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_uid_t=yes-        if ac_fn_c_compute_int "$LINENO" "(uid_t)0.2 - (uid_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-uid_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_uid_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(uid_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(uid_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(uid_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uid_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_uid_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_uid_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_uid_t=LDouble-                else-                    fptools_cv_htype_sup_uid_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((uid_t)(-1)) < ((uid_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uid_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(uid_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uid_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_uid_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_uid_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_uid_t" = no-    then--        fptools_cv_htype_uid_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_uid_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_uid_t" >&5-printf "%s\n" "$fptools_cv_htype_uid_t" >&6; }--printf "%s\n" "#define HTYPE_UID_T $fptools_cv_htype_uid_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for cc_t" >&5-printf %s "checking Haskell type for cc_t... " >&6; }-    if test ${fptools_cv_htype_cc_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_cc_t=yes-        if ac_fn_c_compute_int "$LINENO" "(cc_t)0.2 - (cc_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-cc_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_cc_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(cc_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_cc_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(cc_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_cc_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(cc_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_cc_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_cc_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_cc_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_cc_t=LDouble-                else-                    fptools_cv_htype_sup_cc_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((cc_t)(-1)) < ((cc_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_cc_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(cc_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_cc_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_cc_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_cc_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_cc_t" = no-    then--        fptools_cv_htype_cc_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_cc_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_cc_t" >&5-printf "%s\n" "$fptools_cv_htype_cc_t" >&6; }--printf "%s\n" "#define HTYPE_CC_T $fptools_cv_htype_cc_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for speed_t" >&5-printf %s "checking Haskell type for speed_t... " >&6; }-    if test ${fptools_cv_htype_speed_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_speed_t=yes-        if ac_fn_c_compute_int "$LINENO" "(speed_t)0.2 - (speed_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-speed_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_speed_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(speed_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_speed_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(speed_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_speed_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(speed_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_speed_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_speed_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_speed_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_speed_t=LDouble-                else-                    fptools_cv_htype_sup_speed_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((speed_t)(-1)) < ((speed_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_speed_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(speed_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_speed_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_speed_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_speed_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_speed_t" = no-    then--        fptools_cv_htype_speed_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_speed_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_speed_t" >&5-printf "%s\n" "$fptools_cv_htype_speed_t" >&6; }--printf "%s\n" "#define HTYPE_SPEED_T $fptools_cv_htype_speed_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for tcflag_t" >&5-printf %s "checking Haskell type for tcflag_t... " >&6; }-    if test ${fptools_cv_htype_tcflag_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_tcflag_t=yes-        if ac_fn_c_compute_int "$LINENO" "(tcflag_t)0.2 - (tcflag_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-tcflag_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_tcflag_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(tcflag_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_tcflag_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(tcflag_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_tcflag_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(tcflag_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_tcflag_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_tcflag_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_tcflag_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_tcflag_t=LDouble-                else-                    fptools_cv_htype_sup_tcflag_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((tcflag_t)(-1)) < ((tcflag_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_tcflag_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(tcflag_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_tcflag_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_tcflag_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_tcflag_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_tcflag_t" = no-    then--        fptools_cv_htype_tcflag_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_tcflag_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_tcflag_t" >&5-printf "%s\n" "$fptools_cv_htype_tcflag_t" >&6; }--printf "%s\n" "#define HTYPE_TCFLAG_T $fptools_cv_htype_tcflag_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for nlink_t" >&5-printf %s "checking Haskell type for nlink_t... " >&6; }-    if test ${fptools_cv_htype_nlink_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_nlink_t=yes-        if ac_fn_c_compute_int "$LINENO" "(nlink_t)0.2 - (nlink_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-nlink_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_nlink_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(nlink_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nlink_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(nlink_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nlink_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(nlink_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nlink_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_nlink_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_nlink_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_nlink_t=LDouble-                else-                    fptools_cv_htype_sup_nlink_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((nlink_t)(-1)) < ((nlink_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nlink_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(nlink_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nlink_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_nlink_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_nlink_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_nlink_t" = no-    then--        fptools_cv_htype_nlink_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_nlink_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_nlink_t" >&5-printf "%s\n" "$fptools_cv_htype_nlink_t" >&6; }--printf "%s\n" "#define HTYPE_NLINK_T $fptools_cv_htype_nlink_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for ssize_t" >&5-printf %s "checking Haskell type for ssize_t... " >&6; }-    if test ${fptools_cv_htype_ssize_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_ssize_t=yes-        if ac_fn_c_compute_int "$LINENO" "(ssize_t)0.2 - (ssize_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-ssize_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_ssize_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(ssize_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ssize_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(ssize_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ssize_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(ssize_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ssize_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_ssize_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_ssize_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_ssize_t=LDouble-                else-                    fptools_cv_htype_sup_ssize_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((ssize_t)(-1)) < ((ssize_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ssize_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(ssize_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_ssize_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_ssize_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_ssize_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_ssize_t" = no-    then--        fptools_cv_htype_ssize_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_ssize_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_ssize_t" >&5-printf "%s\n" "$fptools_cv_htype_ssize_t" >&6; }--printf "%s\n" "#define HTYPE_SSIZE_T $fptools_cv_htype_ssize_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for rlim_t" >&5-printf %s "checking Haskell type for rlim_t... " >&6; }-    if test ${fptools_cv_htype_rlim_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_rlim_t=yes-        if ac_fn_c_compute_int "$LINENO" "(rlim_t)0.2 - (rlim_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-rlim_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_rlim_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(rlim_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_rlim_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(rlim_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_rlim_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(rlim_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_rlim_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_rlim_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_rlim_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_rlim_t=LDouble-                else-                    fptools_cv_htype_sup_rlim_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((rlim_t)(-1)) < ((rlim_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_rlim_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(rlim_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_rlim_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_rlim_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_rlim_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_rlim_t" = no-    then--        fptools_cv_htype_rlim_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_rlim_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_rlim_t" >&5-printf "%s\n" "$fptools_cv_htype_rlim_t" >&6; }--printf "%s\n" "#define HTYPE_RLIM_T $fptools_cv_htype_rlim_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for blksize_t" >&5-printf %s "checking Haskell type for blksize_t... " >&6; }-    if test ${fptools_cv_htype_blksize_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_blksize_t=yes-        if ac_fn_c_compute_int "$LINENO" "(blksize_t)0.2 - (blksize_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-blksize_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_blksize_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(blksize_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blksize_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(blksize_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blksize_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(blksize_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blksize_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_blksize_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_blksize_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_blksize_t=LDouble-                else-                    fptools_cv_htype_sup_blksize_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((blksize_t)(-1)) < ((blksize_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blksize_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(blksize_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blksize_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_blksize_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_blksize_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_blksize_t" = no-    then--        fptools_cv_htype_blksize_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_blksize_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_blksize_t" >&5-printf "%s\n" "$fptools_cv_htype_blksize_t" >&6; }--printf "%s\n" "#define HTYPE_BLKSIZE_T $fptools_cv_htype_blksize_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for blkcnt_t" >&5-printf %s "checking Haskell type for blkcnt_t... " >&6; }-    if test ${fptools_cv_htype_blkcnt_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_blkcnt_t=yes-        if ac_fn_c_compute_int "$LINENO" "(blkcnt_t)0.2 - (blkcnt_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-blkcnt_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_blkcnt_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(blkcnt_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blkcnt_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(blkcnt_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blkcnt_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(blkcnt_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blkcnt_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_blkcnt_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_blkcnt_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_blkcnt_t=LDouble-                else-                    fptools_cv_htype_sup_blkcnt_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((blkcnt_t)(-1)) < ((blkcnt_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blkcnt_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(blkcnt_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_blkcnt_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_blkcnt_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_blkcnt_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_blkcnt_t" = no-    then--        fptools_cv_htype_blkcnt_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_blkcnt_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_blkcnt_t" >&5-printf "%s\n" "$fptools_cv_htype_blkcnt_t" >&6; }--printf "%s\n" "#define HTYPE_BLKCNT_T $fptools_cv_htype_blkcnt_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for clockid_t" >&5-printf %s "checking Haskell type for clockid_t... " >&6; }-    if test ${fptools_cv_htype_clockid_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_clockid_t=yes-        if ac_fn_c_compute_int "$LINENO" "(clockid_t)0.2 - (clockid_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-clockid_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_clockid_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(clockid_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clockid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(clockid_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clockid_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(clockid_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clockid_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_clockid_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_clockid_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_clockid_t=LDouble-                else-                    fptools_cv_htype_sup_clockid_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((clockid_t)(-1)) < ((clockid_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clockid_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(clockid_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_clockid_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_clockid_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_clockid_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_clockid_t" = no-    then--        fptools_cv_htype_clockid_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_clockid_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_clockid_t" >&5-printf "%s\n" "$fptools_cv_htype_clockid_t" >&6; }--printf "%s\n" "#define HTYPE_CLOCKID_T $fptools_cv_htype_clockid_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for fsblkcnt_t" >&5-printf %s "checking Haskell type for fsblkcnt_t... " >&6; }-    if test ${fptools_cv_htype_fsblkcnt_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_fsblkcnt_t=yes-        if ac_fn_c_compute_int "$LINENO" "(fsblkcnt_t)0.2 - (fsblkcnt_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-fsblkcnt_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_fsblkcnt_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(fsblkcnt_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsblkcnt_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(fsblkcnt_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsblkcnt_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(fsblkcnt_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsblkcnt_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_fsblkcnt_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_fsblkcnt_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_fsblkcnt_t=LDouble-                else-                    fptools_cv_htype_sup_fsblkcnt_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((fsblkcnt_t)(-1)) < ((fsblkcnt_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsblkcnt_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(fsblkcnt_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsblkcnt_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_fsblkcnt_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_fsblkcnt_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_fsblkcnt_t" = no-    then--        fptools_cv_htype_fsblkcnt_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_fsblkcnt_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_fsblkcnt_t" >&5-printf "%s\n" "$fptools_cv_htype_fsblkcnt_t" >&6; }--printf "%s\n" "#define HTYPE_FSBLKCNT_T $fptools_cv_htype_fsblkcnt_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for fsfilcnt_t" >&5-printf %s "checking Haskell type for fsfilcnt_t... " >&6; }-    if test ${fptools_cv_htype_fsfilcnt_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_fsfilcnt_t=yes-        if ac_fn_c_compute_int "$LINENO" "(fsfilcnt_t)0.2 - (fsfilcnt_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-fsfilcnt_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_fsfilcnt_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(fsfilcnt_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsfilcnt_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(fsfilcnt_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsfilcnt_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(fsfilcnt_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsfilcnt_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_fsfilcnt_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_fsfilcnt_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_fsfilcnt_t=LDouble-                else-                    fptools_cv_htype_sup_fsfilcnt_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((fsfilcnt_t)(-1)) < ((fsfilcnt_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsfilcnt_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(fsfilcnt_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_fsfilcnt_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_fsfilcnt_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_fsfilcnt_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_fsfilcnt_t" = no-    then--        fptools_cv_htype_fsfilcnt_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_fsfilcnt_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_fsfilcnt_t" >&5-printf "%s\n" "$fptools_cv_htype_fsfilcnt_t" >&6; }--printf "%s\n" "#define HTYPE_FSFILCNT_T $fptools_cv_htype_fsfilcnt_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for id_t" >&5-printf %s "checking Haskell type for id_t... " >&6; }-    if test ${fptools_cv_htype_id_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_id_t=yes-        if ac_fn_c_compute_int "$LINENO" "(id_t)0.2 - (id_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-id_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_id_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(id_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_id_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(id_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_id_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(id_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_id_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_id_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_id_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_id_t=LDouble-                else-                    fptools_cv_htype_sup_id_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((id_t)(-1)) < ((id_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_id_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(id_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_id_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_id_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_id_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_id_t" = no-    then--        fptools_cv_htype_id_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_id_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_id_t" >&5-printf "%s\n" "$fptools_cv_htype_id_t" >&6; }--printf "%s\n" "#define HTYPE_ID_T $fptools_cv_htype_id_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for key_t" >&5-printf %s "checking Haskell type for key_t... " >&6; }-    if test ${fptools_cv_htype_key_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_key_t=yes-        if ac_fn_c_compute_int "$LINENO" "(key_t)0.2 - (key_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-key_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_key_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(key_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_key_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(key_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_key_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(key_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_key_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_key_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_key_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_key_t=LDouble-                else-                    fptools_cv_htype_sup_key_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((key_t)(-1)) < ((key_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_key_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(key_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_key_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_key_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_key_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_key_t" = no-    then--        fptools_cv_htype_key_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_key_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_key_t" >&5-printf "%s\n" "$fptools_cv_htype_key_t" >&6; }--printf "%s\n" "#define HTYPE_KEY_T $fptools_cv_htype_key_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for timer_t" >&5-printf %s "checking Haskell type for timer_t... " >&6; }-    if test ${fptools_cv_htype_timer_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_timer_t=yes-        if ac_fn_c_compute_int "$LINENO" "(timer_t)0.2 - (timer_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-timer_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_timer_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(timer_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_timer_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(timer_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_timer_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(timer_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_timer_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_timer_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_timer_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_timer_t=LDouble-                else-                    fptools_cv_htype_sup_timer_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((timer_t)(-1)) < ((timer_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_timer_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(timer_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_timer_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_timer_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_timer_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_timer_t" = no-    then--        fptools_cv_htype_timer_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_timer_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_timer_t" >&5-printf "%s\n" "$fptools_cv_htype_timer_t" >&6; }--printf "%s\n" "#define HTYPE_TIMER_T $fptools_cv_htype_timer_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for socklen_t" >&5-printf %s "checking Haskell type for socklen_t... " >&6; }-    if test ${fptools_cv_htype_socklen_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_socklen_t=yes-        if ac_fn_c_compute_int "$LINENO" "(socklen_t)0.2 - (socklen_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-socklen_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_socklen_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(socklen_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_socklen_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(socklen_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_socklen_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(socklen_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_socklen_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_socklen_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_socklen_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_socklen_t=LDouble-                else-                    fptools_cv_htype_sup_socklen_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((socklen_t)(-1)) < ((socklen_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_socklen_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(socklen_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_socklen_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_socklen_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_socklen_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_socklen_t" = no-    then--        fptools_cv_htype_socklen_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_socklen_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_socklen_t" >&5-printf "%s\n" "$fptools_cv_htype_socklen_t" >&6; }--printf "%s\n" "#define HTYPE_SOCKLEN_T $fptools_cv_htype_socklen_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for nfds_t" >&5-printf %s "checking Haskell type for nfds_t... " >&6; }-    if test ${fptools_cv_htype_nfds_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_nfds_t=yes-        if ac_fn_c_compute_int "$LINENO" "(nfds_t)0.2 - (nfds_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-nfds_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_nfds_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(nfds_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nfds_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(nfds_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nfds_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(nfds_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nfds_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_nfds_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_nfds_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_nfds_t=LDouble-                else-                    fptools_cv_htype_sup_nfds_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((nfds_t)(-1)) < ((nfds_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nfds_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(nfds_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_nfds_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_nfds_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_nfds_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_nfds_t" = no-    then--        fptools_cv_htype_nfds_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_nfds_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_nfds_t" >&5-printf "%s\n" "$fptools_cv_htype_nfds_t" >&6; }--printf "%s\n" "#define HTYPE_NFDS_T $fptools_cv_htype_nfds_t" >>confdefs.h--    fi------------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for intptr_t" >&5-printf %s "checking Haskell type for intptr_t... " >&6; }-    if test ${fptools_cv_htype_intptr_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_intptr_t=yes-        if ac_fn_c_compute_int "$LINENO" "(intptr_t)0.2 - (intptr_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-intptr_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_intptr_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(intptr_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intptr_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(intptr_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intptr_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(intptr_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intptr_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_intptr_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_intptr_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_intptr_t=LDouble-                else-                    fptools_cv_htype_sup_intptr_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((intptr_t)(-1)) < ((intptr_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intptr_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(intptr_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intptr_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_intptr_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_intptr_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_intptr_t" = no-    then--        fptools_cv_htype_intptr_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_intptr_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_intptr_t" >&5-printf "%s\n" "$fptools_cv_htype_intptr_t" >&6; }--printf "%s\n" "#define HTYPE_INTPTR_T $fptools_cv_htype_intptr_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for uintptr_t" >&5-printf %s "checking Haskell type for uintptr_t... " >&6; }-    if test ${fptools_cv_htype_uintptr_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_uintptr_t=yes-        if ac_fn_c_compute_int "$LINENO" "(uintptr_t)0.2 - (uintptr_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-uintptr_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_uintptr_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(uintptr_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintptr_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(uintptr_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintptr_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(uintptr_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintptr_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_uintptr_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_uintptr_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_uintptr_t=LDouble-                else-                    fptools_cv_htype_sup_uintptr_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((uintptr_t)(-1)) < ((uintptr_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintptr_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(uintptr_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintptr_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_uintptr_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_uintptr_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_uintptr_t" = no-    then--        fptools_cv_htype_uintptr_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_uintptr_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_uintptr_t" >&5-printf "%s\n" "$fptools_cv_htype_uintptr_t" >&6; }--printf "%s\n" "#define HTYPE_UINTPTR_T $fptools_cv_htype_uintptr_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for intmax_t" >&5-printf %s "checking Haskell type for intmax_t... " >&6; }-    if test ${fptools_cv_htype_intmax_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_intmax_t=yes-        if ac_fn_c_compute_int "$LINENO" "(intmax_t)0.2 - (intmax_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-intmax_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_intmax_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(intmax_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intmax_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(intmax_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intmax_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(intmax_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intmax_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_intmax_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_intmax_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_intmax_t=LDouble-                else-                    fptools_cv_htype_sup_intmax_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((intmax_t)(-1)) < ((intmax_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intmax_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(intmax_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_intmax_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_intmax_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_intmax_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_intmax_t" = no-    then--        fptools_cv_htype_intmax_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_intmax_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_intmax_t" >&5-printf "%s\n" "$fptools_cv_htype_intmax_t" >&6; }--printf "%s\n" "#define HTYPE_INTMAX_T $fptools_cv_htype_intmax_t" >>confdefs.h--    fi-----------    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Haskell type for uintmax_t" >&5-printf %s "checking Haskell type for uintmax_t... " >&6; }-    if test ${fptools_cv_htype_uintmax_t+y}-then :-  printf %s "(cached) " >&6-else $as_nop--        fptools_cv_htype_sup_uintmax_t=yes-        if ac_fn_c_compute_int "$LINENO" "(uintmax_t)0.2 - (uintmax_t)0.4 < 0 ? 0 : 1" "HTYPE_IS_INTEGRAL"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  HTYPE_IS_INTEGRAL=0-fi---        if test "$HTYPE_IS_INTEGRAL" -eq 0-        then-                                                            cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>--int-main (void)-{-uintmax_t val; *val;--  ;-  return 0;-}-_ACEOF-if ac_fn_c_try_compile "$LINENO"-then :-  HTYPE_IS_POINTER=yes-else $as_nop-  HTYPE_IS_POINTER=no-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext--            if test "$HTYPE_IS_POINTER" = yes-            then-                fptools_cv_htype_uintmax_t="Ptr ()"-            else-                if ac_fn_c_compute_int "$LINENO" "sizeof(uintmax_t) == sizeof(float)" "HTYPE_IS_FLOAT"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintmax_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(uintmax_t) == sizeof(double)" "HTYPE_IS_DOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintmax_t=no-fi--                if ac_fn_c_compute_int "$LINENO" "sizeof(uintmax_t) == sizeof(long double)" "HTYPE_IS_LDOUBLE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintmax_t=no-fi--                if test "$HTYPE_IS_FLOAT" -eq 1-                then-                    fptools_cv_htype_uintmax_t=Float-                elif test "$HTYPE_IS_DOUBLE" -eq 1-                then-                    fptools_cv_htype_uintmax_t=Double-                elif test "$HTYPE_IS_LDOUBLE" -eq 1-                then-                    fptools_cv_htype_uintmax_t=LDouble-                else-                    fptools_cv_htype_sup_uintmax_t=no-                fi-            fi-        else-            if ac_fn_c_compute_int "$LINENO" "((uintmax_t)(-1)) < ((uintmax_t)0)" "HTYPE_IS_SIGNED"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintmax_t=no-fi--            if ac_fn_c_compute_int "$LINENO" "sizeof(uintmax_t) * 8" "HTYPE_SIZE"        "-#include <stdbool.h>-#include <stdio.h>-#include <stddef.h>--#if HAVE_SYS_TYPES_H-# include <sys/types.h>-#endif--#if HAVE_UNISTD_H-# include <unistd.h>-#endif--#if HAVE_SYS_STAT_H-# include <sys/stat.h>-#endif--#if HAVE_FCNTL_H-# include <fcntl.h>-#endif--#if HAVE_SIGNAL_H-# include <signal.h>-#endif--#if HAVE_TIME_H-# include <time.h>-#endif--#if HAVE_TERMIOS_H-# include <termios.h>-#endif--#if HAVE_STRING_H-# include <string.h>-#endif--#if HAVE_CTYPE_H-# include <ctype.h>-#endif--#if HAVE_INTTYPES_H-# include <inttypes.h>-#else-# if HAVE_STDINT_H-#  include <stdint.h>-# endif-#endif--#if HAVE_SYS_RESOURCE_H-# include <sys/resource.h>-#endif--#if HAVE_POLL_H-# include <poll.h>-#endif--#if HAVE_SYS_SOCKET_H-# include <sys/socket.h>-#endif--#include <stdlib.h>-"-then :--else $as_nop-  fptools_cv_htype_sup_uintmax_t=no-fi--            if test "$HTYPE_IS_SIGNED" -eq 0-            then-                fptools_cv_htype_uintmax_t="Word$HTYPE_SIZE"-            else-                fptools_cv_htype_uintmax_t="Int$HTYPE_SIZE"-            fi-        fi--fi--    if test "$fptools_cv_htype_sup_uintmax_t" = no-    then--        fptools_cv_htype_uintmax_t=NotReallyAType-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not supported" >&5-printf "%s\n" "not supported" >&6; }--    fi--            if test "$fptools_cv_htype_sup_uintmax_t" = yes; then-        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fptools_cv_htype_uintmax_t" >&5-printf "%s\n" "$fptools_cv_htype_uintmax_t" >&6; }--printf "%s\n" "#define HTYPE_UINTMAX_T $fptools_cv_htype_uintmax_t" >>confdefs.h--    fi----# test errno values-for fp_const_name in E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBADRPC EBUSY ECHILD ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDIRTY EDOM EDQUOT EEXIST EFAULT EFBIG EFTYPE EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG ENONET ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE EPROCLIM EPROCUNAVAIL EPROGMISMATCH EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EROFS ERPCMISMATCH ERREMOTE ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV ENOCIGAR ENOTSUP-do-as_fp_Cache=`printf "%s\n" "fp_cv_const_$fp_const_name" | $as_tr_sh`-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking value of $fp_const_name" >&5-printf %s "checking value of $fp_const_name... " >&6; }-if eval test \${$as_fp_Cache+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if ac_fn_c_compute_int "$LINENO" "$fp_const_name" "fp_check_const_result"        "#include <stdio.h>-#include <errno.h>-"-then :--else $as_nop-  fp_check_const_result='-1'-fi--eval "$as_fp_Cache=\$fp_check_const_result"-fi-eval ac_res=\$$as_fp_Cache-	       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5-printf "%s\n" "$ac_res" >&6; }-cat >>confdefs.h <<_ACEOF-#define `printf "%s\n" "CONST_$fp_const_name" | $as_tr_cpp` `eval 'as_val=${'$as_fp_Cache'};printf "%s\n" "$as_val"'`-_ACEOF--done---# we need SIGINT in TopHandler.lhs-for fp_const_name in SIGINT-do-as_fp_Cache=`printf "%s\n" "fp_cv_const_$fp_const_name" | $as_tr_sh`-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking value of $fp_const_name" >&5-printf %s "checking value of $fp_const_name... " >&6; }-if eval test \${$as_fp_Cache+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if ac_fn_c_compute_int "$LINENO" "$fp_const_name" "fp_check_const_result"        "-#if HAVE_SIGNAL_H-#include <signal.h>-#endif-"-then :--else $as_nop-  fp_check_const_result='-1'-fi--eval "$as_fp_Cache=\$fp_check_const_result"-fi-eval ac_res=\$$as_fp_Cache-	       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5-printf "%s\n" "$ac_res" >&6; }-cat >>confdefs.h <<_ACEOF-#define `printf "%s\n" "CONST_$fp_const_name" | $as_tr_cpp` `eval 'as_val=${'$as_fp_Cache'};printf "%s\n" "$as_val"'`-_ACEOF--done---{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking value of O_BINARY" >&5-printf %s "checking value of O_BINARY... " >&6; }-if test ${fp_cv_const_O_BINARY+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if ac_fn_c_compute_int "$LINENO" "O_BINARY" "fp_check_const_result"        "#include <fcntl.h>-"-then :--else $as_nop-  fp_check_const_result=0-fi--fp_cv_const_O_BINARY=$fp_check_const_result-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $fp_cv_const_O_BINARY" >&5-printf "%s\n" "$fp_cv_const_O_BINARY" >&6; }-printf "%s\n" "#define CONST_O_BINARY $fp_cv_const_O_BINARY" >>confdefs.h---# We don't use iconv or libcharset on Windows, but if configure finds-# them then it can cause problems. So we don't even try looking if-# we are on Windows.-# See http://www.haskell.org/pipermail/cvs-ghc/2011-September/065980.html-if test "$WINDOWS" = "NO"-then--# We can't just use AC_SEARCH_LIBS for this, as on OpenBSD the iconv.h-# header needs to be included as iconv_open is #define'd to something-# else. We therefore use our own FP_SEARCH_LIBS_PROTO, which allows us-# to give prototype text.-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing iconv" >&5-printf %s "checking for library containing iconv... " >&6; }-if test ${ac_cv_search_iconv+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_func_search_save_LIBS=$LIBS-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */--#include <stddef.h>-#include <iconv.h>--int-main (void)-{-iconv_t cd;-                      cd = iconv_open("", "");-                      iconv(cd,NULL,NULL,NULL,NULL);-                      iconv_close(cd);-  ;-  return 0;-}-_ACEOF-for ac_lib in '' iconv; do-  if test -z "$ac_lib"; then-    ac_res="none required"-  else-    ac_res=-l$ac_lib-    LIBS="-l$ac_lib  $ac_func_search_save_LIBS"-  fi-  if ac_fn_c_try_link "$LINENO"-then :-  ac_cv_search_iconv=$ac_res-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam \-    conftest$ac_exeext-  if test ${ac_cv_search_iconv+y}-then :-  break-fi-done-if test ${ac_cv_search_iconv+y}-then :--else $as_nop-  ac_cv_search_iconv=no-fi-rm conftest.$ac_ext-LIBS=$ac_func_search_save_LIBS-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_iconv" >&5-printf "%s\n" "$ac_cv_search_iconv" >&6; }-ac_res=$ac_cv_search_iconv-if test "$ac_res" != no-then :-  test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"-  EXTRA_LIBS="$EXTRA_LIBS $ac_lib"-else $as_nop-  as_fn_error $? "iconv is required on non-Windows platforms" "$LINENO" 5-fi--# If possible, we use libcharset instead of nl_langinfo(CODESET) to-# determine the current locale's character encoding.  Allow the user-# to disable this with --without-libcharset if they don't want a-# dependency on libcharset.--# Check whether --with-libcharset was given.-if test ${with_libcharset+y}-then :-  withval=$with_libcharset;-else $as_nop-  with_libcharset=check-fi---if test "x$with_libcharset" != xno-then :-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing locale_charset" >&5-printf %s "checking for library containing locale_charset... " >&6; }-if test ${ac_cv_search_locale_charset+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  ac_func_search_save_LIBS=$LIBS-cat confdefs.h - <<_ACEOF >conftest.$ac_ext-/* end confdefs.h.  */-#include <libcharset.h>-int-main (void)-{-const char* charset = locale_charset();-  ;-  return 0;-}-_ACEOF-for ac_lib in '' charset; do-  if test -z "$ac_lib"; then-    ac_res="none required"-  else-    ac_res=-l$ac_lib-    LIBS="-l$ac_lib  $ac_func_search_save_LIBS"-  fi-  if ac_fn_c_try_link "$LINENO"-then :-  ac_cv_search_locale_charset=$ac_res-fi-rm -f core conftest.err conftest.$ac_objext conftest.beam \-    conftest$ac_exeext-  if test ${ac_cv_search_locale_charset+y}-then :-  break-fi-done-if test ${ac_cv_search_locale_charset+y}-then :--else $as_nop-  ac_cv_search_locale_charset=no-fi-rm conftest.$ac_ext-LIBS=$ac_func_search_save_LIBS-fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_locale_charset" >&5-printf "%s\n" "$ac_cv_search_locale_charset" >&6; }-ac_res=$ac_cv_search_locale_charset-if test "$ac_res" != no-then :-  test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"--printf "%s\n" "#define HAVE_LIBCHARSET 1" >>confdefs.h--     EXTRA_LIBS="$EXTRA_LIBS $ac_lib"--fi-fi--fi--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 :--else $as_nop-  as_fn_error $? "internal error" "$LINENO" 5-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]];'.-# This bug is HP SR number 8606223364.-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of struct MD5Context" >&5-printf %s "checking size of struct MD5Context... " >&6; }-if test ${ac_cv_sizeof_struct_MD5Context+y}-then :-  printf %s "(cached) " >&6-else $as_nop-  if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (struct MD5Context))" "ac_cv_sizeof_struct_MD5Context"        "#include \"include/md5.h\"-"-then :--else $as_nop-  if test "$ac_cv_type_struct_MD5Context" = yes; then-     { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5-printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}-as_fn_error 77 "cannot compute sizeof (struct MD5Context)-See \`config.log' for more details" "$LINENO" 5; }-   else-     ac_cv_sizeof_struct_MD5Context=0-   fi-fi--fi-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_struct_MD5Context" >&5-printf "%s\n" "$ac_cv_sizeof_struct_MD5Context" >&6; }----printf "%s\n" "#define SIZEOF_STRUCT_MD5CONTEXT $ac_cv_sizeof_struct_MD5Context" >>confdefs.h-----ac_config_files="$ac_config_files base.buildinfo"---cat >confcache <<\_ACEOF-# This file is a shell script that caches the results of configure-# tests run on this system so they can be shared between configure-# scripts and configure runs, see configure's option --config-cache.-# It is not useful on other systems.  If it contains results you don't-# want to keep, you may remove or edit it.-#-# config.status only pays attention to the cache file if you give it-# the --recheck option to rerun configure.-#-# `ac_cv_env_foo' variables (set or unset) will be overridden when-# loading this file, other *unset* `ac_cv_foo' will be assigned the-# following values.--_ACEOF--# The following way of writing the cache mishandles newlines in values,-# but we know of no workaround that is simple, portable, and efficient.-# So, we kill variables containing newlines.-# Ultrix sh set writes to stderr and can't be redirected directly,-# and sets the high bit in the cache file unless we assign to the vars.-(-  for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do-    eval ac_val=\$$ac_var-    case $ac_val in #(-    *${as_nl}*)-      case $ac_var in #(-      *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5-printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;-      esac-      case $ac_var in #(-      _ | IFS | as_nl) ;; #(-      BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(-      *) { eval $ac_var=; unset $ac_var;} ;;-      esac ;;-    esac-  done--  (set) 2>&1 |-    case $as_nl`(ac_space=' '; set) 2>&1` in #(-    *${as_nl}ac_space=\ *)-      # `set' does not quote correctly, so add quotes: double-quote-      # substitution turns \\\\ into \\, and sed turns \\ into \.-      sed -n \-	"s/'/'\\\\''/g;-	  s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"-      ;; #(-    *)-      # `set' quotes correctly as required by POSIX, so do not add quotes.-      sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"-      ;;-    esac |-    sort-) |-  sed '-     /^ac_cv_env_/b end-     t clear-     :clear-     s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/-     t end-     s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/-     :end' >>confcache-if diff "$cache_file" confcache >/dev/null 2>&1; then :; else-  if test -w "$cache_file"; then-    if test "x$cache_file" != "x/dev/null"; then-      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5-printf "%s\n" "$as_me: updating cache $cache_file" >&6;}-      if test ! -f "$cache_file" || test -h "$cache_file"; then-	cat confcache >"$cache_file"-      else-        case $cache_file in #(-        */* | ?:*)-	  mv -f confcache "$cache_file"$$ &&-	  mv -f "$cache_file"$$ "$cache_file" ;; #(-        *)-	  mv -f confcache "$cache_file" ;;-	esac-      fi-    fi-  else-    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5-printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;}-  fi-fi-rm -f confcache--test "x$prefix" = xNONE && prefix=$ac_default_prefix-# Let make expand exec_prefix.-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'--DEFS=-DHAVE_CONFIG_H--ac_libobjs=-ac_ltlibobjs=-U=-for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue-  # 1. Remove the extension, and $U if already installed.-  ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'-  ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"`-  # 2. Prepend LIBOBJDIR.  When used with automake>=1.10 LIBOBJDIR-  #    will be set to the directory where LIBOBJS objects are built.-  as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext"-  as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo'-done-LIBOBJS=$ac_libobjs--LTLIBOBJS=$ac_ltlibobjs----: "${CONFIG_STATUS=./config.status}"-ac_write_fail=0-ac_clean_files_save=$ac_clean_files-ac_clean_files="$ac_clean_files $CONFIG_STATUS"-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5-printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;}-as_write_fail=0-cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1-#! $SHELL-# Generated by $as_me.-# Run this file to recreate the current configuration.-# Compiler output produced by configure, useful for debugging-# configure, is in config.log if it exists.--debug=false-ac_cs_recheck=false-ac_cs_silent=false--SHELL=\${CONFIG_SHELL-$SHELL}-export SHELL-_ASEOF-cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1-## -------------------- ##-## M4sh Initialization. ##-## -------------------- ##--# Be more Bourne compatible-DUALCASE=1; export DUALCASE # for MKS sh-as_nop=:-if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1-then :-  emulate sh-  NULLCMD=:-  # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which-  # is contrary to our usage.  Disable this feature.-  alias -g '${1+"$@"}'='"$@"'-  setopt NO_GLOB_SUBST-else $as_nop-  case `(set -o) 2>/dev/null` in #(-  *posix*) :-    set -o posix ;; #(-  *) :-     ;;-esac-fi----# Reset variables that may have inherited troublesome values from-# the environment.--# IFS needs to be set, to space, tab, and newline, in precisely that order.-# (If _AS_PATH_WALK were called with IFS unset, it would have the-# side effect of setting IFS to empty, thus disabling word splitting.)-# Quoting is to prevent editors from complaining about space-tab.-as_nl='-'-export as_nl-IFS=" ""	$as_nl"--PS1='$ '-PS2='> '-PS4='+ '--# Ensure predictable behavior from utilities with locale-dependent output.-LC_ALL=C-export LC_ALL-LANGUAGE=C-export LANGUAGE--# We cannot yet rely on "unset" to work, but we need these variables-# to be unset--not just set to an empty or harmless value--now, to-# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh).  This construct-# also avoids known problems related to "unset" and subshell syntax-# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).-for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH-do eval test \${$as_var+y} \-  && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :-done--# Ensure that fds 0, 1, and 2 are open.-if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi-if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi-if (exec 3>&2)            ; then :; else exec 2>/dev/null; fi--# The user is always right.-if ${PATH_SEPARATOR+false} :; then-  PATH_SEPARATOR=:-  (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {-    (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||-      PATH_SEPARATOR=';'-  }-fi---# Find who we are.  Look in the path if we contain no directory separator.-as_myself=-case $0 in #((-  *[\\/]* ) as_myself=$0 ;;-  *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR-for as_dir in $PATH-do-  IFS=$as_save_IFS-  case $as_dir in #(((-    '') as_dir=./ ;;-    */) ;;-    *) as_dir=$as_dir/ ;;-  esac-    test -r "$as_dir$0" && as_myself=$as_dir$0 && break-  done-IFS=$as_save_IFS--     ;;-esac-# We did not find ourselves, most probably we were run as `sh COMMAND'-# in which case we are not to be found in the path.-if test "x$as_myself" = x; then-  as_myself=$0-fi-if test ! -f "$as_myself"; then-  printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2-  exit 1-fi----# as_fn_error STATUS ERROR [LINENO LOG_FD]-# -----------------------------------------# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are-# provided, also output the error to LOG_FD, referencing LINENO. Then exit the-# script with STATUS, using 1 if that was 0.-as_fn_error ()-{-  as_status=$1; test $as_status -eq 0 && as_status=1-  if test "$4"; then-    as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack-    printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4-  fi-  printf "%s\n" "$as_me: error: $2" >&2-  as_fn_exit $as_status-} # as_fn_error----# as_fn_set_status STATUS-# ------------------------# Set $? to STATUS, without forking.-as_fn_set_status ()-{-  return $1-} # as_fn_set_status--# as_fn_exit STATUS-# ------------------# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.-as_fn_exit ()-{-  set +e-  as_fn_set_status $1-  exit $1-} # as_fn_exit--# as_fn_unset VAR-# ----------------# Portably unset VAR.-as_fn_unset ()-{-  { eval $1=; unset $1;}-}-as_unset=as_fn_unset--# as_fn_append VAR VALUE-# -----------------------# Append the text in VALUE to the end of the definition contained in VAR. Take-# advantage of any shell optimizations that allow amortized linear growth over-# repeated appends, instead of the typical quadratic growth present in naive-# implementations.-if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null-then :-  eval 'as_fn_append ()-  {-    eval $1+=\$2-  }'-else $as_nop-  as_fn_append ()-  {-    eval $1=\$$1\$2-  }-fi # as_fn_append--# as_fn_arith ARG...-# -------------------# Perform arithmetic evaluation on the ARGs, and store the result in the-# global $as_val. Take advantage of shells that can avoid forks. The arguments-# must be portable across $(()) and expr.-if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null-then :-  eval 'as_fn_arith ()-  {-    as_val=$(( $* ))-  }'-else $as_nop-  as_fn_arith ()-  {-    as_val=`expr "$@" || test $? -eq 1`-  }-fi # as_fn_arith---if expr a : '\(a\)' >/dev/null 2>&1 &&-   test "X`expr 00001 : '.*\(...\)'`" = X001; then-  as_expr=expr-else-  as_expr=false-fi--if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then-  as_basename=basename-else-  as_basename=false-fi--if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then-  as_dirname=dirname-else-  as_dirname=false-fi--as_me=`$as_basename -- "$0" ||-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \-	 X"$0" : 'X\(//\)$' \| \-	 X"$0" : 'X\(/\)' \| . 2>/dev/null ||-printf "%s\n" X/"$0" |-    sed '/^.*\/\([^/][^/]*\)\/*$/{-	    s//\1/-	    q-	  }-	  /^X\/\(\/\/\)$/{-	    s//\1/-	    q-	  }-	  /^X\/\(\/\).*/{-	    s//\1/-	    q-	  }-	  s/.*/./; q'`--# Avoid depending upon Character Ranges.-as_cr_letters='abcdefghijklmnopqrstuvwxyz'-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'-as_cr_Letters=$as_cr_letters$as_cr_LETTERS-as_cr_digits='0123456789'-as_cr_alnum=$as_cr_Letters$as_cr_digits---# Determine whether it's possible to make 'echo' print without a newline.-# These variables are no longer used directly by Autoconf, but are AC_SUBSTed-# for compatibility with existing Makefiles.-ECHO_C= ECHO_N= ECHO_T=-case `echo -n x` in #(((((--n*)-  case `echo 'xy\c'` in-  *c*) ECHO_T='	';;	# ECHO_T is single tab character.-  xy)  ECHO_C='\c';;-  *)   echo `echo ksh88 bug on AIX 6.1` > /dev/null-       ECHO_T='	';;-  esac;;-*)-  ECHO_N='-n';;-esac--# For backward compatibility with old third-party macros, we provide-# the shell variables $as_echo and $as_echo_n.  New code should use-# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.-as_echo='printf %s\n'-as_echo_n='printf %s'--rm -f conf$$ conf$$.exe conf$$.file-if test -d conf$$.dir; then-  rm -f conf$$.dir/conf$$.file-else-  rm -f conf$$.dir-  mkdir conf$$.dir 2>/dev/null-fi-if (echo >conf$$.file) 2>/dev/null; then-  if ln -s conf$$.file conf$$ 2>/dev/null; then-    as_ln_s='ln -s'-    # ... but there are two gotchas:-    # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.-    # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.-    # In both cases, we have to default to `cp -pR'.-    ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||-      as_ln_s='cp -pR'-  elif ln conf$$.file conf$$ 2>/dev/null; then-    as_ln_s=ln-  else-    as_ln_s='cp -pR'-  fi-else-  as_ln_s='cp -pR'-fi-rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file-rmdir conf$$.dir 2>/dev/null---# as_fn_mkdir_p-# --------------# Create "$as_dir" as a directory, including parents if necessary.-as_fn_mkdir_p ()-{--  case $as_dir in #(-  -*) as_dir=./$as_dir;;-  esac-  test -d "$as_dir" || eval $as_mkdir_p || {-    as_dirs=-    while :; do-      case $as_dir in #(-      *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(-      *) as_qdir=$as_dir;;-      esac-      as_dirs="'$as_qdir' $as_dirs"-      as_dir=`$as_dirname -- "$as_dir" ||-$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \-	 X"$as_dir" : 'X\(//\)[^/]' \| \-	 X"$as_dir" : 'X\(//\)$' \| \-	 X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||-printf "%s\n" X"$as_dir" |-    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)[^/].*/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\).*/{-	    s//\1/-	    q-	  }-	  s/.*/./; q'`-      test -d "$as_dir" && break-    done-    test -z "$as_dirs" || eval "mkdir $as_dirs"-  } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"---} # as_fn_mkdir_p-if mkdir -p . 2>/dev/null; then-  as_mkdir_p='mkdir -p "$as_dir"'-else-  test -d ./-p && rmdir ./-p-  as_mkdir_p=false-fi---# as_fn_executable_p FILE-# ------------------------# Test if FILE is an executable regular file.-as_fn_executable_p ()-{-  test -f "$1" && test -x "$1"-} # as_fn_executable_p-as_test_x='test -x'-as_executable_p=as_fn_executable_p--# Sed expression to map a string onto a valid CPP name.-as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"--# Sed expression to map a string onto a valid variable name.-as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"---exec 6>&1-## ----------------------------------- ##-## Main body of $CONFIG_STATUS script. ##-## ----------------------------------- ##-_ASEOF-test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-# Save the log message, to keep $0 and so on meaningful, and to-# report actual input values of CONFIG_FILES etc. instead of their-# values after options handling.-ac_log="-This file was extended by Haskell base package $as_me 1.0, which was-generated by GNU Autoconf 2.71.  Invocation command line was--  CONFIG_FILES    = $CONFIG_FILES-  CONFIG_HEADERS  = $CONFIG_HEADERS-  CONFIG_LINKS    = $CONFIG_LINKS-  CONFIG_COMMANDS = $CONFIG_COMMANDS-  $ $0 $@--on `(hostname || uname -n) 2>/dev/null | sed 1q`-"--_ACEOF--case $ac_config_files in *"-"*) set x $ac_config_files; shift; ac_config_files=$*;;-esac--case $ac_config_headers in *"-"*) set x $ac_config_headers; shift; ac_config_headers=$*;;-esac---cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-# Files that config.status was made for.-config_files="$ac_config_files"-config_headers="$ac_config_headers"--_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-ac_cs_usage="\-\`$as_me' instantiates files and other configuration actions-from templates according to the current configuration.  Unless the files-and actions are specified as TAGs, all are instantiated by default.--Usage: $0 [OPTION]... [TAG]...--  -h, --help       print this help, then exit-  -V, --version    print version number and configuration settings, then exit-      --config     print configuration, then exit-  -q, --quiet, --silent-                   do not print progress messages-  -d, --debug      don't remove temporary files-      --recheck    update $as_me by reconfiguring in the same conditions-      --file=FILE[:TEMPLATE]-                   instantiate the configuration file FILE-      --header=FILE[:TEMPLATE]-                   instantiate the configuration header FILE--Configuration files:-$config_files--Configuration headers:-$config_headers--Report bugs to <libraries@haskell.org>."--_ACEOF-ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"`-ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"`-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-ac_cs_config='$ac_cs_config_escaped'-ac_cs_version="\\-Haskell base package config.status 1.0-configured by $0, generated by GNU Autoconf 2.71,-  with options \\"\$ac_cs_config\\"--Copyright (C) 2021 Free Software Foundation, Inc.-This config.status script is free software; the Free Software Foundation-gives unlimited permission to copy, distribute and modify it."--ac_pwd='$ac_pwd'-srcdir='$srcdir'-test -n "\$AWK" || AWK=awk-_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-# The default lists apply if the user does not specify any file.-ac_need_defaults=:-while test $# != 0-do-  case $1 in-  --*=?*)-    ac_option=`expr "X$1" : 'X\([^=]*\)='`-    ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`-    ac_shift=:-    ;;-  --*=)-    ac_option=`expr "X$1" : 'X\([^=]*\)='`-    ac_optarg=-    ac_shift=:-    ;;-  *)-    ac_option=$1-    ac_optarg=$2-    ac_shift=shift-    ;;-  esac--  case $ac_option in-  # Handling of the options.-  -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)-    ac_cs_recheck=: ;;-  --version | --versio | --versi | --vers | --ver | --ve | --v | -V )-    printf "%s\n" "$ac_cs_version"; exit ;;-  --config | --confi | --conf | --con | --co | --c )-    printf "%s\n" "$ac_cs_config"; exit ;;-  --debug | --debu | --deb | --de | --d | -d )-    debug=: ;;-  --file | --fil | --fi | --f )-    $ac_shift-    case $ac_optarg in-    *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;-    '') as_fn_error $? "missing file argument" ;;-    esac-    as_fn_append CONFIG_FILES " '$ac_optarg'"-    ac_need_defaults=false;;-  --header | --heade | --head | --hea )-    $ac_shift-    case $ac_optarg in-    *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;-    esac-    as_fn_append CONFIG_HEADERS " '$ac_optarg'"-    ac_need_defaults=false;;-  --he | --h)-    # Conflict between --help and --header-    as_fn_error $? "ambiguous option: \`$1'-Try \`$0 --help' for more information.";;-  --help | --hel | -h )-    printf "%s\n" "$ac_cs_usage"; exit ;;-  -q | -quiet | --quiet | --quie | --qui | --qu | --q \-  | -silent | --silent | --silen | --sile | --sil | --si | --s)-    ac_cs_silent=: ;;--  # This is an error.-  -*) as_fn_error $? "unrecognized option: \`$1'-Try \`$0 --help' for more information." ;;--  *) as_fn_append ac_config_targets " $1"-     ac_need_defaults=false ;;--  esac-  shift-done--ac_configure_extra_args=--if $ac_cs_silent; then-  exec 6>/dev/null-  ac_configure_extra_args="$ac_configure_extra_args --silent"-fi--_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-if \$ac_cs_recheck; then-  set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion-  shift-  \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6-  CONFIG_SHELL='$SHELL'-  export CONFIG_SHELL-  exec "\$@"-fi--_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-exec 5>>config.log-{-  echo-  sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX-## Running $as_me. ##-_ASBOX-  printf "%s\n" "$ac_log"-} >&5--_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1--# Handling of arguments.-for ac_config_target in $ac_config_targets-do-  case $ac_config_target in-    "include/HsBaseConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/HsBaseConfig.h" ;;-    "include/EventConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/EventConfig.h" ;;-    "base.buildinfo") CONFIG_FILES="$CONFIG_FILES base.buildinfo" ;;--  *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;-  esac-done---# If the user did not use the arguments to specify the items to instantiate,-# then the envvar interface is used.  Set only those that are not.-# We use the long form for the default assignment because of an extremely-# bizarre bug on SunOS 4.1.3.-if $ac_need_defaults; then-  test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files-  test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers-fi--# Have a temporary directory for convenience.  Make it in the build tree-# simply because there is no reason against having it here, and in addition,-# creating and moving files from /tmp can sometimes cause problems.-# Hook for its removal unless debugging.-# Note that there is a small window in which the directory will not be cleaned:-# after its creation but before its name has been assigned to `$tmp'.-$debug ||-{-  tmp= ac_tmp=-  trap 'exit_status=$?-  : "${ac_tmp:=$tmp}"-  { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status-' 0-  trap 'as_fn_exit 1' 1 2 13 15-}-# Create a (secure) tmp directory for tmp files.--{-  tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&-  test -d "$tmp"-}  ||-{-  tmp=./conf$$-$RANDOM-  (umask 077 && mkdir "$tmp")-} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5-ac_tmp=$tmp--# Set up the scripts for CONFIG_FILES section.-# No need to generate them if there are no CONFIG_FILES.-# This happens for instance with `./config.status config.h'.-if test -n "$CONFIG_FILES"; then---ac_cr=`echo X | tr X '\015'`-# On cygwin, bash can eat \r inside `` if the user requested igncr.-# But we know of no other shell where ac_cr would be empty at this-# point, so we can use a bashism as a fallback.-if test "x$ac_cr" = x; then-  eval ac_cr=\$\'\\r\'-fi-ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null`-if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then-  ac_cs_awk_cr='\\r'-else-  ac_cs_awk_cr=$ac_cr-fi--echo 'BEGIN {' >"$ac_tmp/subs1.awk" &&-_ACEOF---{-  echo "cat >conf$$subs.awk <<_ACEOF" &&-  echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' &&-  echo "_ACEOF"-} >conf$$subs.sh ||-  as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5-ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'`-ac_delim='%!_!# '-for ac_last_try in false false false false false :; do-  . ./conf$$subs.sh ||-    as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5--  ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X`-  if test $ac_delim_n = $ac_delim_num; then-    break-  elif $ac_last_try; then-    as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5-  else-    ac_delim="$ac_delim!$ac_delim _$ac_delim!! "-  fi-done-rm -f conf$$subs.sh--cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK &&-_ACEOF-sed -n '-h-s/^/S["/; s/!.*/"]=/-p-g-s/^[^!]*!//-:repl-t repl-s/'"$ac_delim"'$//-t delim-:nl-h-s/\(.\{148\}\)..*/\1/-t more1-s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/-p-n-b repl-:more1-s/["\\]/\\&/g; s/^/"/; s/$/"\\/-p-g-s/.\{148\}//-t nl-:delim-h-s/\(.\{148\}\)..*/\1/-t more2-s/["\\]/\\&/g; s/^/"/; s/$/"/-p-b-:more2-s/["\\]/\\&/g; s/^/"/; s/$/"\\/-p-g-s/.\{148\}//-t delim-' <conf$$subs.awk | sed '-/^[^""]/{-  N-  s/\n//-}-' >>$CONFIG_STATUS || ac_write_fail=1-rm -f conf$$subs.awk-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-_ACAWK-cat >>"\$ac_tmp/subs1.awk" <<_ACAWK &&-  for (key in S) S_is_set[key] = 1-  FS = ""--}-{-  line = $ 0-  nfields = split(line, field, "@")-  substed = 0-  len = length(field[1])-  for (i = 2; i < nfields; i++) {-    key = field[i]-    keylen = length(key)-    if (S_is_set[key]) {-      value = S[key]-      line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3)-      len += length(value) + length(field[++i])-      substed = 1-    } else-      len += 1 + keylen-  }--  print line-}--_ACAWK-_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then-  sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g"-else-  cat-fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \-  || as_fn_error $? "could not setup config files machinery" "$LINENO" 5-_ACEOF--# VPATH may cause trouble with some makes, so we remove sole $(srcdir),-# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and-# trailing colons and then remove the whole line if VPATH becomes empty-# (actually we leave an empty line to preserve line numbers).-if test "x$srcdir" = x.; then-  ac_vpsub='/^[	 ]*VPATH[	 ]*=[	 ]*/{-h-s///-s/^/:/-s/[	 ]*$/:/-s/:\$(srcdir):/:/g-s/:\${srcdir}:/:/g-s/:@srcdir@:/:/g-s/^:*//-s/:*$//-x-s/\(=[	 ]*\).*/\1/-G-s/\n//-s/^[^=]*=[	 ]*$//-}'-fi--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-fi # test -n "$CONFIG_FILES"--# Set up the scripts for CONFIG_HEADERS section.-# No need to generate them if there are no CONFIG_HEADERS.-# This happens for instance with `./config.status Makefile'.-if test -n "$CONFIG_HEADERS"; then-cat >"$ac_tmp/defines.awk" <<\_ACAWK ||-BEGIN {-_ACEOF--# Transform confdefs.h into an awk script `defines.awk', embedded as-# here-document in config.status, that substitutes the proper values into-# config.h.in to produce config.h.--# Create a delimiter string that does not exist in confdefs.h, to ease-# handling of long lines.-ac_delim='%!_!# '-for ac_last_try in false false :; do-  ac_tt=`sed -n "/$ac_delim/p" confdefs.h`-  if test -z "$ac_tt"; then-    break-  elif $ac_last_try; then-    as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5-  else-    ac_delim="$ac_delim!$ac_delim _$ac_delim!! "-  fi-done--# For the awk script, D is an array of macro values keyed by name,-# likewise P contains macro parameters if any.  Preserve backslash-# newline sequences.--ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]*-sed -n '-s/.\{148\}/&'"$ac_delim"'/g-t rset-:rset-s/^[	 ]*#[	 ]*define[	 ][	 ]*/ /-t def-d-:def-s/\\$//-t bsnl-s/["\\]/\\&/g-s/^ \('"$ac_word_re"'\)\(([^()]*)\)[	 ]*\(.*\)/P["\1"]="\2"\-D["\1"]=" \3"/p-s/^ \('"$ac_word_re"'\)[	 ]*\(.*\)/D["\1"]=" \2"/p-d-:bsnl-s/["\\]/\\&/g-s/^ \('"$ac_word_re"'\)\(([^()]*)\)[	 ]*\(.*\)/P["\1"]="\2"\-D["\1"]=" \3\\\\\\n"\\/p-t cont-s/^ \('"$ac_word_re"'\)[	 ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p-t cont-d-:cont-n-s/.\{148\}/&'"$ac_delim"'/g-t clear-:clear-s/\\$//-t bsnlc-s/["\\]/\\&/g; s/^/"/; s/$/"/p-d-:bsnlc-s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p-b cont-' <confdefs.h | sed '-s/'"$ac_delim"'/"\\\-"/g' >>$CONFIG_STATUS || ac_write_fail=1--cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-  for (key in D) D_is_set[key] = 1-  FS = ""-}-/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ {-  line = \$ 0-  split(line, arg, " ")-  if (arg[1] == "#") {-    defundef = arg[2]-    mac1 = arg[3]-  } else {-    defundef = substr(arg[1], 2)-    mac1 = arg[2]-  }-  split(mac1, mac2, "(") #)-  macro = mac2[1]-  prefix = substr(line, 1, index(line, defundef) - 1)-  if (D_is_set[macro]) {-    # Preserve the white space surrounding the "#".-    print prefix "define", macro P[macro] D[macro]-    next-  } else {-    # Replace #undef with comments.  This is necessary, for example,-    # in the case of _POSIX_SOURCE, which is predefined and required-    # on some systems where configure will not decide to define it.-    if (defundef == "undef") {-      print "/*", prefix defundef, macro, "*/"-      next-    }-  }-}-{ print }-_ACAWK-_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-  as_fn_error $? "could not setup config headers machinery" "$LINENO" 5-fi # test -n "$CONFIG_HEADERS"---eval set X "  :F $CONFIG_FILES  :H $CONFIG_HEADERS    "-shift-for ac_tag-do-  case $ac_tag in-  :[FHLC]) ac_mode=$ac_tag; continue;;-  esac-  case $ac_mode$ac_tag in-  :[FHL]*:*);;-  :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;-  :[FH]-) ac_tag=-:-;;-  :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;-  esac-  ac_save_IFS=$IFS-  IFS=:-  set x $ac_tag-  IFS=$ac_save_IFS-  shift-  ac_file=$1-  shift--  case $ac_mode in-  :L) ac_source=$1;;-  :[FH])-    ac_file_inputs=-    for ac_f-    do-      case $ac_f in-      -) ac_f="$ac_tmp/stdin";;-      *) # Look for the file first in the build tree, then in the source tree-	 # (if the path is not absolute).  The absolute path cannot be DOS-style,-	 # because $ac_f cannot contain `:'.-	 test -f "$ac_f" ||-	   case $ac_f in-	   [\\/$]*) false;;-	   *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;-	   esac ||-	   as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;-      esac-      case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac-      as_fn_append ac_file_inputs " '$ac_f'"-    done--    # Let's still pretend it is `configure' which instantiates (i.e., don't-    # use $as_me), people would be surprised to read:-    #    /* config.h.  Generated by config.status.  */-    configure_input='Generated from '`-	  printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'-	`' by configure.'-    if test x"$ac_file" != x-; then-      configure_input="$ac_file.  $configure_input"-      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5-printf "%s\n" "$as_me: creating $ac_file" >&6;}-    fi-    # Neutralize special characters interpreted by sed in replacement strings.-    case $configure_input in #(-    *\&* | *\|* | *\\* )-       ac_sed_conf_input=`printf "%s\n" "$configure_input" |-       sed 's/[\\\\&|]/\\\\&/g'`;; #(-    *) ac_sed_conf_input=$configure_input;;-    esac--    case $ac_tag in-    *:-:* | *:-) cat >"$ac_tmp/stdin" \-      || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;-    esac-    ;;-  esac--  ac_dir=`$as_dirname -- "$ac_file" ||-$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \-	 X"$ac_file" : 'X\(//\)[^/]' \| \-	 X"$ac_file" : 'X\(//\)$' \| \-	 X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||-printf "%s\n" X"$ac_file" |-    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)[^/].*/{-	    s//\1/-	    q-	  }-	  /^X\(\/\/\)$/{-	    s//\1/-	    q-	  }-	  /^X\(\/\).*/{-	    s//\1/-	    q-	  }-	  s/.*/./; q'`-  as_dir="$ac_dir"; as_fn_mkdir_p-  ac_builddir=.--case "$ac_dir" in-.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;-*)-  ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`-  # A ".." for each directory in $ac_dir_suffix.-  ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`-  case $ac_top_builddir_sub in-  "") ac_top_builddir_sub=. ac_top_build_prefix= ;;-  *)  ac_top_build_prefix=$ac_top_builddir_sub/ ;;-  esac ;;-esac-ac_abs_top_builddir=$ac_pwd-ac_abs_builddir=$ac_pwd$ac_dir_suffix-# for backward compatibility:-ac_top_builddir=$ac_top_build_prefix--case $srcdir in-  .)  # We are building in place.-    ac_srcdir=.-    ac_top_srcdir=$ac_top_builddir_sub-    ac_abs_top_srcdir=$ac_pwd ;;-  [\\/]* | ?:[\\/]* )  # Absolute name.-    ac_srcdir=$srcdir$ac_dir_suffix;-    ac_top_srcdir=$srcdir-    ac_abs_top_srcdir=$srcdir ;;-  *) # Relative name.-    ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix-    ac_top_srcdir=$ac_top_build_prefix$srcdir-    ac_abs_top_srcdir=$ac_pwd/$srcdir ;;-esac-ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix---  case $ac_mode in-  :F)-  #-  # CONFIG_FILE-  #--_ACEOF--cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-# If the template does not know about datarootdir, expand it.-# FIXME: This hack should be removed a few years after 2.60.-ac_datarootdir_hack=; ac_datarootdir_seen=-ac_sed_dataroot='-/datarootdir/ {-  p-  q-}-/@datadir@/p-/@docdir@/p-/@infodir@/p-/@localedir@/p-/@mandir@/p'-case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in-*datarootdir*) ac_datarootdir_seen=yes;;-*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5-printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}-_ACEOF-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-  ac_datarootdir_hack='-  s&@datadir@&$datadir&g-  s&@docdir@&$docdir&g-  s&@infodir@&$infodir&g-  s&@localedir@&$localedir&g-  s&@mandir@&$mandir&g-  s&\\\${datarootdir}&$datarootdir&g' ;;-esac-_ACEOF--# Neutralize VPATH when `$srcdir' = `.'.-# Shell code in configure.ac might set extrasub.-# FIXME: do we really want to maintain this feature?-cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1-ac_sed_extra="$ac_vpsub-$extrasub-_ACEOF-cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1-:t-/@[a-zA-Z_][a-zA-Z_0-9]*@/!b-s|@configure_input@|$ac_sed_conf_input|;t t-s&@top_builddir@&$ac_top_builddir_sub&;t t-s&@top_build_prefix@&$ac_top_build_prefix&;t t-s&@srcdir@&$ac_srcdir&;t t-s&@abs_srcdir@&$ac_abs_srcdir&;t t-s&@top_srcdir@&$ac_top_srcdir&;t t-s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t-s&@builddir@&$ac_builddir&;t t-s&@abs_builddir@&$ac_abs_builddir&;t t-s&@abs_top_builddir@&$ac_abs_top_builddir&;t t-$ac_datarootdir_hack-"-eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \-  >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5--test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&-  { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&-  { ac_out=`sed -n '/^[	 ]*datarootdir[	 ]*:*=/p' \-      "$ac_tmp/out"`; test -z "$ac_out"; } &&-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'-which seems to be undefined.  Please make sure it is defined" >&5-printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'-which seems to be undefined.  Please make sure it is defined" >&2;}--  rm -f "$ac_tmp/stdin"-  case $ac_file in-  -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;-  *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;-  esac \-  || as_fn_error $? "could not create $ac_file" "$LINENO" 5- ;;-  :H)-  #-  # CONFIG_HEADER-  #-  if test x"$ac_file" != x-; then-    {-      printf "%s\n" "/* $configure_input  */" >&1 \-      && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs"-    } >"$ac_tmp/config.h" \-      || as_fn_error $? "could not create $ac_file" "$LINENO" 5-    if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then-      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5-printf "%s\n" "$as_me: $ac_file is unchanged" >&6;}-    else-      rm -f "$ac_file"-      mv "$ac_tmp/config.h" "$ac_file" \-	|| as_fn_error $? "could not create $ac_file" "$LINENO" 5-    fi-  else-    printf "%s\n" "/* $configure_input  */" >&1 \-      && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \-      || as_fn_error $? "could not create -" "$LINENO" 5-  fi- ;;---  esac--done # for ac_tag---as_fn_exit 0-_ACEOF-ac_clean_files=$ac_clean_files_save--test $ac_write_fail = 0 ||-  as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5---# configure is writing to config.log, and then calls config.status.-# config.status does its own redirection, appending to config.log.-# Unfortunately, on DOS this fails, as config.log is still kept open-# by configure, so config.status won't be able to write to it; its-# output is simply discarded.  So we exec the FD to /dev/null,-# effectively closing config.log, so it can be properly (re)opened and-# appended to by config.status.  When coming back to configure, we-# need to make the FD available again.-if test "$no_create" != yes; then-  ac_cs_success=:-  ac_config_status_args=-  test "$silent" = yes &&-    ac_config_status_args="$ac_config_status_args --quiet"-  exec 5>/dev/null-  $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false-  exec 5>>config.log-  # Use ||, not &&, to avoid exiting from the if with $? = 1, which-  # would make configure fail if this is the last instruction.-  $ac_cs_success || as_fn_exit 1-fi-if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then-  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5-printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}-fi--
− configure.ac 
@@ -1,246 +0,0 @@-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.-AC_CONFIG_SRCDIR([include/HsBase.h])--AC_CONFIG_HEADERS([include/HsBaseConfig.h include/EventConfig.h])--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_alias in-    *mingw32*|*mingw64*|*cygwin*|*msys*)-        WINDOWS=YES;;-    *)-        WINDOWS=NO;;-esac-AC_MSG_RESULT($WINDOWS)--# do we have long longs?-AC_CHECK_TYPES([long long])--# check for specific header (.h) files that we are interested in-AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/file.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h poll.h sys/epoll.h sys/event.h sys/eventfd.h sys/socket.h])--# Enable large file support. Do this before testing the types ino_t, off_t, and-# rlim_t, because it will affect the result of that test.-AC_SYS_LARGEFILE--dnl ** check for wide-char classifications-dnl FreeBSD has an empty wctype.h, so test one of the affected-dnl functions if it's really there.-AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)])--AC_CHECK_FUNCS([lstat])-AC_CHECK_LIB([rt], [clock_gettime])-AC_CHECK_FUNCS([clock_gettime])-AC_CHECK_FUNCS([getclock getrusage times])-AC_CHECK_FUNCS([_chsize ftruncate])--# event-related fun-# The line below already defines HAVE_KQUEUE and HAVE_POLL, so technically some of the-# subsequent portions that redefine them could be skipped. However, we keep those portions-# to keep kqueue/poll in line with HAVE_EPOLL and possible other additions in the future. You-# should be aware of this peculiarity if you try to simulate not having kqueue or poll by-# moving away header files (see also https://gitlab.haskell.org/ghc/ghc/-/issues/9283)-AC_CHECK_FUNCS([epoll_ctl eventfd kevent kevent64 kqueue poll])--if test "$ac_cv_header_sys_epoll_h" = yes && test "$ac_cv_func_epoll_ctl" = yes; then-  AC_DEFINE([HAVE_EPOLL], [1], [Define if you have epoll support.])-fi--if test "$ac_cv_header_sys_event_h" = yes && test "$ac_cv_func_kqueue" = yes; then-  AC_DEFINE([HAVE_KQUEUE], [1], [Define if you have kqueue support.])--  AC_CHECK_SIZEOF([kev.filter], [], [#include <sys/event.h>-struct kevent kev;])--  AC_CHECK_SIZEOF([kev.flags], [], [#include <sys/event.h>-struct kevent kev;])-fi--if test "$ac_cv_header_poll_h" = yes && test "$ac_cv_func_poll" = yes; then-  AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.])-fi--# Linux open file descriptor locks-AC_CHECK_DECL([F_OFD_SETLK], [-  AC_DEFINE([HAVE_OFD_LOCKING], [1], [Define if you have open file descriptor lock support.])-], [], [-  #include <unistd.h>-  #include <fcntl.h>-])--# flock-AC_CHECK_FUNCS([flock])-if test "$ac_cv_header_sys_file_h" = yes && test "$ac_cv_func_flock" = yes; then-  AC_DEFINE([HAVE_FLOCK], [1], [Define if you have flock support.])-fi--# unsetenv-AC_CHECK_FUNCS([unsetenv])--###  POSIX.1003.1 unsetenv returns 0 or -1 (EINVAL), but older implementations-###  in common use return void.-AC_CACHE_CHECK([return type of unsetenv], fptools_cv_func_unsetenv_return_type,-  [AC_EGREP_HEADER(changequote(<, >)<void[      ]+unsetenv>changequote([, ]),-                   stdlib.h,-                   [fptools_cv_func_unsetenv_return_type=void],-                   [fptools_cv_func_unsetenv_return_type=int])])-case "$fptools_cv_func_unsetenv_return_type" in-  "void" )-    AC_DEFINE([UNSETENV_RETURNS_VOID], [1], [Define if stdlib.h declares unsetenv to return void.])-  ;;-esac--dnl---------------------------------------------------------------------dnl * Deal with arguments telling us iconv is somewhere odd-dnl----------------------------------------------------------------------AC_ARG_WITH([iconv-includes],-  [AS_HELP_STRING([--with-iconv-includes],-    [directory containing iconv.h])],-    [ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval $CPPFLAGS"],-    [ICONV_INCLUDE_DIRS=])--AC_ARG_WITH([iconv-libraries],-  [AS_HELP_STRING([--with-iconv-libraries],-    [directory containing iconv library])],-    [ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval $LDFLAGS"],-    [ICONV_LIB_DIRS=])--AC_SUBST(ICONV_INCLUDE_DIRS)-AC_SUBST(ICONV_LIB_DIRS)--# map standard C types and ISO types to Haskell types-FPTOOLS_CHECK_HTYPE(char)-FPTOOLS_CHECK_HTYPE(signed char)-FPTOOLS_CHECK_HTYPE(unsigned char)-FPTOOLS_CHECK_HTYPE(short)-FPTOOLS_CHECK_HTYPE(unsigned short)-FPTOOLS_CHECK_HTYPE(int)-FPTOOLS_CHECK_HTYPE(unsigned int)-FPTOOLS_CHECK_HTYPE(long)-FPTOOLS_CHECK_HTYPE(unsigned long)-if test "$ac_cv_type_long_long" = yes; then-FPTOOLS_CHECK_HTYPE(long long)-FPTOOLS_CHECK_HTYPE(unsigned long long)-fi-FPTOOLS_CHECK_HTYPE(bool)-FPTOOLS_CHECK_HTYPE(float)-FPTOOLS_CHECK_HTYPE(double)-FPTOOLS_CHECK_HTYPE(ptrdiff_t)-FPTOOLS_CHECK_HTYPE(size_t)-FPTOOLS_CHECK_HTYPE(wchar_t)-FPTOOLS_CHECK_HTYPE(sig_atomic_t)-FPTOOLS_CHECK_HTYPE(clock_t)-FPTOOLS_CHECK_HTYPE(time_t)-FPTOOLS_CHECK_HTYPE(useconds_t)-FPTOOLS_CHECK_HTYPE_ELSE(suseconds_t,-                         [if test "$WINDOWS" = "YES"-                          then-                              AC_CV_NAME=Int32-                              AC_CV_NAME_supported=yes-                          else-                              AC_MSG_ERROR([type not found])-                          fi])-FPTOOLS_CHECK_HTYPE(dev_t)-FPTOOLS_CHECK_HTYPE(ino_t)-FPTOOLS_CHECK_HTYPE(mode_t)-FPTOOLS_CHECK_HTYPE(off_t)-FPTOOLS_CHECK_HTYPE(pid_t)-FPTOOLS_CHECK_HTYPE(gid_t)-FPTOOLS_CHECK_HTYPE(uid_t)-FPTOOLS_CHECK_HTYPE(cc_t)-FPTOOLS_CHECK_HTYPE(speed_t)-FPTOOLS_CHECK_HTYPE(tcflag_t)-FPTOOLS_CHECK_HTYPE(nlink_t)-FPTOOLS_CHECK_HTYPE(ssize_t)-FPTOOLS_CHECK_HTYPE(rlim_t)-FPTOOLS_CHECK_HTYPE(blksize_t)-FPTOOLS_CHECK_HTYPE(blkcnt_t)-FPTOOLS_CHECK_HTYPE(clockid_t)-FPTOOLS_CHECK_HTYPE(fsblkcnt_t)-FPTOOLS_CHECK_HTYPE(fsfilcnt_t)-FPTOOLS_CHECK_HTYPE(id_t)-FPTOOLS_CHECK_HTYPE(key_t)-FPTOOLS_CHECK_HTYPE(timer_t)-FPTOOLS_CHECK_HTYPE(socklen_t)-FPTOOLS_CHECK_HTYPE(nfds_t)--FPTOOLS_CHECK_HTYPE(intptr_t)-FPTOOLS_CHECK_HTYPE(uintptr_t)-FPTOOLS_CHECK_HTYPE(intmax_t)-FPTOOLS_CHECK_HTYPE(uintmax_t)--# test errno values-FP_CHECK_CONSTS([E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBADRPC EBUSY ECHILD ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDIRTY EDOM EDQUOT EEXIST EFAULT EFBIG EFTYPE EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG ENONET ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE EPROCLIM EPROCUNAVAIL EPROGMISMATCH EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EROFS ERPCMISMATCH ERREMOTE ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV ENOCIGAR ENOTSUP], [#include <stdio.h>-#include <errno.h>])--# we need SIGINT in TopHandler.lhs-FP_CHECK_CONSTS([SIGINT], [-#if HAVE_SIGNAL_H-#include <signal.h>-#endif])--dnl ** can we open files in binary mode?-FP_CHECK_CONST([O_BINARY], [#include <fcntl.h>], [0])--# We don't use iconv or libcharset on Windows, but if configure finds-# them then it can cause problems. So we don't even try looking if-# we are on Windows.-# See http://www.haskell.org/pipermail/cvs-ghc/2011-September/065980.html-if test "$WINDOWS" = "NO"-then--# We can't just use AC_SEARCH_LIBS for this, as on OpenBSD the iconv.h-# header needs to be included as iconv_open is #define'd to something-# else. We therefore use our own FP_SEARCH_LIBS_PROTO, which allows us-# to give prototype text.-FP_SEARCH_LIBS_PROTO(iconv,-                     [-#include <stddef.h>-#include <iconv.h>-                      ],-                     [iconv_t cd;-                      cd = iconv_open("", "");-                      iconv(cd,NULL,NULL,NULL,NULL);-                      iconv_close(cd);],-                     iconv,-                     [EXTRA_LIBS="$EXTRA_LIBS $ac_lib"],-                     [AC_MSG_ERROR([iconv is required on non-Windows platforms])])--# If possible, we use libcharset instead of nl_langinfo(CODESET) to-# determine the current locale's character encoding.  Allow the user-# to disable this with --without-libcharset if they don't want a-# dependency on libcharset.-AC_ARG_WITH([libcharset],-  [AS_HELP_STRING([--with-libcharset],-    [Use libcharset [default=only if available]])],-  [],-  [with_libcharset=check])--AS_IF([test "x$with_libcharset" != xno],-  FP_SEARCH_LIBS_PROTO(-    [locale_charset],-    [#include <libcharset.h>],-    [const char* charset = locale_charset();],-    [charset],-    [AC_DEFINE([HAVE_LIBCHARSET], [1], [Define to 1 if you have libcharset.])-     EXTRA_LIBS="$EXTRA_LIBS $ac_lib"]-  ))--fi--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], [], [AC_MSG_ERROR([internal error])], [#include "include/md5.h"])-AC_CHECK_SIZEOF([struct MD5Context], [], [#include "include/md5.h"])--AC_SUBST(EXTRA_LIBS)-AC_CONFIG_FILES([base.buildinfo])--AC_OUTPUT
− include/CTypes.h 
@@ -1,39 +0,0 @@-{- ---------------------------------------------------------------------------// Dirty CPP hackery for CTypes/CTypesISO-//-// (c) The FFI task force, 2000-// ----------------------------------------------------------------------------}--#pragma once--{--// As long as there is no automatic derivation of classes for newtypes we resort-// to extremely dirty cpp-hackery.   :-P   Some care has to be taken when the-// macros below are modified, otherwise the layout rule will bite you.--}----  // GHC can derive any class for a newtype, so we make use of that here...--#define ARITHMETIC_CLASSES  Eq,Ord,Num,Enum,Storable,Real-#define INTEGRAL_CLASSES Bounded,Integral,Bits,FiniteBits-#define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat-#define OPAQUE_CLASSES Eq,Ord,Storable--#define ARITHMETIC_TYPE(T,THE_CTYPE,B) \-newtype {-# CTYPE THE_CTYPE #-} T = T B deriving newtype (Read, Show, ARITHMETIC_CLASSES);--#define INTEGRAL_TYPE(T,THE_CTYPE,B) \-newtype {-# CTYPE THE_CTYPE #-} T = T B \-    deriving newtype (Read, Show, ARITHMETIC_CLASSES, INTEGRAL_CLASSES, Ix);--#define FLOATING_TYPE(T,THE_CTYPE,B) \-newtype {-# CTYPE THE_CTYPE #-} T = T B deriving newtype (Read, Show, ARITHMETIC_CLASSES, FLOATING_CLASSES);--#define FLOATING_TYPE_WITH_CTYPE(T,THE_CTYPE,B) \-newtype {-# CTYPE THE_CTYPE #-} T = T B \-    deriving newtype (Read, Show, ARITHMETIC_CLASSES, FLOATING_CLASSES);--#define OPAQUE_TYPE(T,THE_CTYPE,B) \-newtype {-# CTYPE THE_CTYPE #-} T = T (B) \-    deriving newtype (Show, OPAQUE_CLASSES);
− include/EventConfig.h.in 
@@ -1,91 +0,0 @@-/* include/EventConfig.h.in.  Generated from configure.ac by autoheader.  */--/* Define if you have epoll support. */-#undef HAVE_EPOLL--/* Define to 1 if you have the `epoll_create1' function. */-#undef HAVE_EPOLL_CREATE1--/* Define to 1 if you have the `epoll_ctl' function. */-#undef HAVE_EPOLL_CTL--/* Define to 1 if you have the `eventfd' function. */-#undef HAVE_EVENTFD--/* Define to 1 if you have the <inttypes.h> header file. */-#undef HAVE_INTTYPES_H--/* Define to 1 if you have the `kevent' function. */-#undef HAVE_KEVENT--/* Define to 1 if you have the `kevent64' function. */-#undef HAVE_KEVENT64--/* Define if you have kqueue support. */-#undef HAVE_KQUEUE--/* Define to 1 if you have the <memory.h> header file. */-#undef HAVE_MEMORY_H--/* Define if you have poll support. */-#undef HAVE_POLL--/* Define to 1 if you have the <poll.h> header file. */-#undef HAVE_POLL_H--/* Define to 1 if you have the <signal.h> header file. */-#undef HAVE_SIGNAL_H--/* Define to 1 if you have the <stdint.h> header file. */-#undef HAVE_STDINT_H--/* Define to 1 if you have the <stdlib.h> header file. */-#undef HAVE_STDLIB_H--/* Define to 1 if you have the <strings.h> header file. */-#undef HAVE_STRINGS_H--/* Define to 1 if you have the <string.h> header file. */-#undef HAVE_STRING_H--/* Define to 1 if you have the <sys/epoll.h> header file. */-#undef HAVE_SYS_EPOLL_H--/* Define to 1 if you have the <sys/eventfd.h> header file. */-#undef HAVE_SYS_EVENTFD_H--/* Define to 1 if you have the <sys/event.h> header file. */-#undef HAVE_SYS_EVENT_H--/* Define to 1 if you have the <sys/stat.h> header file. */-#undef HAVE_SYS_STAT_H--/* Define to 1 if you have the <sys/types.h> header file. */-#undef HAVE_SYS_TYPES_H--/* Define to 1 if you have the <unistd.h> header file. */-#undef HAVE_UNISTD_H--/* Define to the address where bug reports for this package should be sent. */-#undef PACKAGE_BUGREPORT--/* Define to the full name of this package. */-#undef PACKAGE_NAME--/* Define to the full name and version of this package. */-#undef PACKAGE_STRING--/* Define to the one symbol short name of this package. */-#undef PACKAGE_TARNAME--/* Define to the version of this package. */-#undef PACKAGE_VERSION--/* Define to 1 if you have the ANSI C header files. */-#undef STDC_HEADERS--/* The size of `kev.filter', as computed by sizeof. */-#undef SIZEOF_KEV_FILTER--/* The size of `kev.flags', as computed by sizeof. */-#undef SIZEOF_KEV_FLAGS
− include/HsBase.h 
@@ -1,568 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The University of Glasgow 2001-2004- *- * Definitions for package `base' which are visible in Haskell land.- *- * ---------------------------------------------------------------------------*/--#pragma once--#include "HsBaseConfig.h"--/* ultra-evil... */-#undef PACKAGE_BUGREPORT-#undef PACKAGE_NAME-#undef PACKAGE_STRING-#undef PACKAGE_TARNAME-#undef PACKAGE_VERSION--/* Needed to get the macro version of errno on some OSs (eg. Solaris).-   We must do this, because these libs are only compiled once, but-   must work in both single-threaded and multi-threaded programs. */-#define _REENTRANT 1--#include "HsFFI.h"--#include <stdbool.h>-#include <stdio.h>-#include <stdlib.h>-#include <math.h>--#if HAVE_SYS_TYPES_H-#include <sys/types.h>-#endif-#if HAVE_UNISTD_H-#include <unistd.h>-#endif-#if HAVE_SYS_STAT_H-#include <sys/stat.h>-#endif-#if HAVE_FCNTL_H-# include <fcntl.h>-#endif-#if HAVE_TERMIOS_H-#include <termios.h>-#endif-#if HAVE_SIGNAL_H-#include <signal.h>-/* Ultra-ugly: OpenBSD uses broken macros for sigemptyset and sigfillset (missing casts) */-#if __OpenBSD__-#undef sigemptyset-#undef sigfillset-#endif-#endif-#if HAVE_ERRNO_H-#include <errno.h>-#endif-#if HAVE_STRING_H-#include <string.h>-#endif-#if HAVE_UTIME_H-#include <utime.h>-#endif-#if HAVE_SYS_UTSNAME_H-#include <sys/utsname.h>-#endif-#if HAVE_GETTIMEOFDAY-#  if HAVE_SYS_TIME_H-#   include <sys/time.h>-#  endif-#elif HAVE_GETCLOCK-# if HAVE_SYS_TIMERS_H-#  define POSIX_4D9 1-#  include <sys/timers.h>-# endif-#endif-#if HAVE_TIME_H-#include <time.h>-#endif-#if HAVE_SYS_TIMEB_H && !defined(__FreeBSD__)-#include <sys/timeb.h>-#endif-#if HAVE_WINDOWS_H-#include <windows.h>-#endif-#if HAVE_SYS_TIMES_H-#include <sys/times.h>-#endif-#if HAVE_WINSOCK_H && defined(_WIN32)-#include <winsock.h>-#endif-#if HAVE_LIMITS_H-#include <limits.h>-#endif-#if HAVE_WCTYPE_H-#include <wctype.h>-#endif-#if HAVE_INTTYPES_H-# include <inttypes.h>-#elif HAVE_STDINT_H-# include <stdint.h>-#endif-#if defined(HAVE_CLOCK_GETTIME)-# if defined(_POSIX_MONOTONIC_CLOCK)-#  define CLOCK_ID CLOCK_MONOTONIC-# else-#  define CLOCK_ID CLOCK_REALTIME-# endif-#elif defined(darwin_HOST_OS)-# include <mach/mach.h>-# include <mach/mach_time.h>-#endif--#if !defined(_WIN32)-# if HAVE_SYS_RESOURCE_H-#  include <sys/resource.h>-# endif-#endif--#if !HAVE_GETRUSAGE && HAVE_SYS_SYSCALL_H-# include <sys/syscall.h>-# if defined(SYS_GETRUSAGE)	/* hpux_HOST_OS */-#  define getrusage(a, b)  syscall(SYS_GETRUSAGE, a, b)-#  define HAVE_GETRUSAGE 1-# endif-#endif--/* For System */-#if HAVE_SYS_WAIT_H-#include <sys/wait.h>-#endif-#if HAVE_VFORK_H-#include <vfork.h>-#endif-#include "WCsubst.h"--#if defined(_WIN32)-/* in Win32Utils.c */-extern void maperrno (void);-extern int maperrno_func(DWORD dwErrorCode);-extern HsWord64 getMonotonicUSec(void);-#endif--#if defined(_WIN32)-#include <io.h>-#include <fcntl.h>-#include <shlobj.h>-#include <share.h>-#endif--#if HAVE_SYS_SELECT_H-#include <sys/select.h>-#endif--/* in inputReady.c */-extern int fdReady(int fd, bool write, int64_t msecs, bool isSock);--/* ------------------------------------------------------------------------------   INLINE functions.--   These functions are given as inlines here for when compiling via C,-   but we also generate static versions into the cbits library for-   when compiling to native code.-   -------------------------------------------------------------------------- */--#if !defined(INLINE)-# if defined(_MSC_VER)-#  define INLINE extern __inline-# else-#  define INLINE static inline-# endif-#endif--INLINE int __hscore_get_errno(void) { return errno; }-INLINE void __hscore_set_errno(int e) { errno = e; }--INLINE HsInt-__hscore_bufsiz(void)-{-  return BUFSIZ;-}--INLINE int-__hscore_o_binary(void)-{-#if defined(_MSC_VER)-  return O_BINARY;-#else-  return CONST_O_BINARY;-#endif-}--INLINE int-__hscore_o_rdonly(void)-{-#if defined(O_RDONLY)-  return O_RDONLY;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_wronly( void )-{-#if defined(O_WRONLY)-  return O_WRONLY;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_rdwr( void )-{-#if defined(O_RDWR)-  return O_RDWR;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_append( void )-{-#if defined(O_APPEND)-  return O_APPEND;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_creat( void )-{-#if defined(O_CREAT)-  return O_CREAT;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_excl( void )-{-#if defined(O_EXCL)-  return O_EXCL;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_trunc( void )-{-#if defined(O_TRUNC)-  return O_TRUNC;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_noctty( void )-{-#if defined(O_NOCTTY)-  return O_NOCTTY;-#else-  return 0;-#endif-}--INLINE int-__hscore_o_nonblock( void )-{-#if defined(O_NONBLOCK)-  return O_NONBLOCK;-#else-  return 0;-#endif-}--INLINE int-__hscore_ftruncate( int fd, off_t where )-{-#if defined(HAVE_FTRUNCATE)-  return ftruncate(fd,where);-#elif defined(HAVE__CHSIZE)-  return _chsize(fd,where);-#else-// ToDo: we should use _chsize_s() on Windows which allows a 64-bit-// offset, but it doesn't seem to be available from mingw at this time-// --SDM (01/2008)-#error at least ftruncate or _chsize functions are required to build-#endif-}--INLINE int-__hscore_setmode( int fd, HsBool toBin )-{-#if defined(_WIN32)-  return _setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT);-#else-  return 0;-#endif-}--#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-// hFileSize and hSeek will work with large files, hSetFileSize will not.-typedef struct _stati64 struct_stat;-typedef off64_t stsize_t;-#else-typedef struct stat struct_stat;-typedef off_t stsize_t;-#endif--INLINE HsInt-__hscore_sizeof_stat( void )-{-  return sizeof(struct_stat);-}--INLINE time_t __hscore_st_mtime ( struct_stat* st ) { return st->st_mtime; }-INLINE stsize_t __hscore_st_size  ( struct_stat* st ) { return st->st_size; }-#if !defined(_MSC_VER)-INLINE mode_t __hscore_st_mode  ( struct_stat* st ) { return st->st_mode; }-INLINE dev_t  __hscore_st_dev  ( struct_stat* st ) { return st->st_dev; }-INLINE ino_t  __hscore_st_ino  ( struct_stat* st ) { return st->st_ino; }-#endif--#if defined(_WIN32)-INLINE int __hscore_stat(wchar_t *file, struct_stat *buf) {-	return _wstati64(file,buf);-}--INLINE int __hscore_fstat(int fd, struct_stat *buf) {-	return _fstati64(fd,buf);-}-INLINE int __hscore_lstat(wchar_t *fname, struct_stat *buf )-{-	return _wstati64(fname,buf);-}-#else-INLINE int __hscore_stat(char *file, struct_stat *buf) {-	return stat(file,buf);-}--INLINE int __hscore_fstat(int fd, struct_stat *buf) {-	return fstat(fd,buf);-}--INLINE int __hscore_lstat( const char *fname, struct stat *buf )-{-#if HAVE_LSTAT-  return lstat(fname, buf);-#else-  return stat(fname, buf);-#endif-}-#endif--#if HAVE_TERMIOS_H-INLINE tcflag_t __hscore_lflag( struct termios* ts ) { return ts->c_lflag; }--INLINE void-__hscore_poke_lflag( struct termios* ts, tcflag_t t ) { ts->c_lflag = t; }--INLINE unsigned char*-__hscore_ptr_c_cc( struct termios* ts )-{ return (unsigned char*) &ts->c_cc; }--INLINE HsInt-__hscore_sizeof_termios( void )-{-#if !defined(_WIN32)-  return sizeof(struct termios);-#else-  return 0;-#endif-}-#endif--#if !defined(_WIN32)-INLINE HsInt-__hscore_sizeof_sigset_t( void )-{-  return sizeof(sigset_t);-}-#endif--INLINE int-__hscore_echo( void )-{-#if defined(ECHO)-  return ECHO;-#else-  return 0;-#endif--}--INLINE int-__hscore_tcsanow( void )-{-#if defined(TCSANOW)-  return TCSANOW;-#else-  return 0;-#endif--}--INLINE int-__hscore_icanon( void )-{-#if defined(ICANON)-  return ICANON;-#else-  return 0;-#endif-}--INLINE int __hscore_vmin( void )-{-#if defined(VMIN)-  return VMIN;-#else-  return 0;-#endif-}--INLINE int __hscore_vtime( void )-{-#if defined(VTIME)-  return VTIME;-#else-  return 0;-#endif-}--INLINE int __hscore_sigttou( void )-{-#if defined(SIGTTOU)-  return SIGTTOU;-#else-  return 0;-#endif-}--INLINE int __hscore_sig_block( void )-{-#if defined(SIG_BLOCK)-  return SIG_BLOCK;-#else-  return 0;-#endif-}--INLINE int __hscore_sig_setmask( void )-{-#if defined(SIG_SETMASK)-  return SIG_SETMASK;-#else-  return 0;-#endif-}--#if !defined(_WIN32)-INLINE size_t __hscore_sizeof_siginfo_t (void)-{-    return sizeof(siginfo_t);-}-#endif--INLINE int-__hscore_f_getfl( void )-{-#if defined(F_GETFL)-  return F_GETFL;-#else-  return 0;-#endif-}--INLINE int-__hscore_f_setfl( void )-{-#if defined(F_SETFL)-  return F_SETFL;-#else-  return 0;-#endif-}--INLINE int-__hscore_f_setfd( void )-{-#if defined(F_SETFD)-  return F_SETFD;-#else-  return 0;-#endif-}--INLINE long-__hscore_fd_cloexec( void )-{-#if defined(FD_CLOEXEC)-  return FD_CLOEXEC;-#else-  return 0;-#endif-}--// defined in rts/RtsStartup.c.-extern void* __hscore_get_saved_termios(int fd);-extern void __hscore_set_saved_termios(int fd, void* ts);--#if defined(_WIN32)-/* Defined in fs.c.  */-extern int __hs_swopen (const wchar_t* filename, int oflag, int shflag,-                        int pmode);--INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) {-  int result = -1;-	if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))-	  result = __hs_swopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode);-          // _O_NOINHERIT: see #2650-	else-	  result = __hs_swopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode);-          // _O_NOINHERIT: see #2650--  /* This call is very important, otherwise the I/O system will not propagate-     the correct error for why it failed.  */-  if (result == -1)-      maperrno ();--  return result;-}-#else-INLINE int __hscore_open(char *file, int how, mode_t mode) {-	return open(file,how,mode);-}-#endif--#if darwin_HOST_OS-// You should not access _environ directly on Darwin in a bundle/shared library.-// See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html-#include <crt_externs.h>-INLINE char **__hscore_environ(void) { return *(_NSGetEnviron()); }-#else-/* ToDo: write a feature test that doesn't assume 'environ' to- *    be in scope at link-time. */-extern char** environ;-INLINE char **__hscore_environ(void) { return environ; }-#endif--/* lossless conversions between pointers and integral types */-INLINE void *    __hscore_from_uintptr(uintptr_t n) { return (void *)n; }-INLINE void *    __hscore_from_intptr (intptr_t n)  { return (void *)n; }-INLINE uintptr_t __hscore_to_uintptr  (void *p)     { return (uintptr_t)p; }-INLINE intptr_t  __hscore_to_intptr   (void *p)     { return (intptr_t)p; }--void errorBelch2(const char*s, char *t);-void debugBelch2(const char*s, char *t);
− include/HsBaseConfig.h.in 
@@ -1,760 +0,0 @@-/* include/HsBaseConfig.h.in.  Generated from configure.ac by autoheader.  */--/* The value of E2BIG. */-#undef CONST_E2BIG--/* The value of EACCES. */-#undef CONST_EACCES--/* The value of EADDRINUSE. */-#undef CONST_EADDRINUSE--/* The value of EADDRNOTAVAIL. */-#undef CONST_EADDRNOTAVAIL--/* The value of EADV. */-#undef CONST_EADV--/* The value of EAFNOSUPPORT. */-#undef CONST_EAFNOSUPPORT--/* The value of EAGAIN. */-#undef CONST_EAGAIN--/* The value of EALREADY. */-#undef CONST_EALREADY--/* The value of EBADF. */-#undef CONST_EBADF--/* The value of EBADMSG. */-#undef CONST_EBADMSG--/* The value of EBADRPC. */-#undef CONST_EBADRPC--/* The value of EBUSY. */-#undef CONST_EBUSY--/* The value of ECHILD. */-#undef CONST_ECHILD--/* The value of ECOMM. */-#undef CONST_ECOMM--/* The value of ECONNABORTED. */-#undef CONST_ECONNABORTED--/* The value of ECONNREFUSED. */-#undef CONST_ECONNREFUSED--/* The value of ECONNRESET. */-#undef CONST_ECONNRESET--/* The value of EDEADLK. */-#undef CONST_EDEADLK--/* The value of EDESTADDRREQ. */-#undef CONST_EDESTADDRREQ--/* The value of EDIRTY. */-#undef CONST_EDIRTY--/* The value of EDOM. */-#undef CONST_EDOM--/* The value of EDQUOT. */-#undef CONST_EDQUOT--/* The value of EEXIST. */-#undef CONST_EEXIST--/* The value of EFAULT. */-#undef CONST_EFAULT--/* The value of EFBIG. */-#undef CONST_EFBIG--/* The value of EFTYPE. */-#undef CONST_EFTYPE--/* The value of EHOSTDOWN. */-#undef CONST_EHOSTDOWN--/* The value of EHOSTUNREACH. */-#undef CONST_EHOSTUNREACH--/* The value of EIDRM. */-#undef CONST_EIDRM--/* The value of EILSEQ. */-#undef CONST_EILSEQ--/* The value of EINPROGRESS. */-#undef CONST_EINPROGRESS--/* The value of EINTR. */-#undef CONST_EINTR--/* The value of EINVAL. */-#undef CONST_EINVAL--/* The value of EIO. */-#undef CONST_EIO--/* The value of EISCONN. */-#undef CONST_EISCONN--/* The value of EISDIR. */-#undef CONST_EISDIR--/* The value of ELOOP. */-#undef CONST_ELOOP--/* The value of EMFILE. */-#undef CONST_EMFILE--/* The value of EMLINK. */-#undef CONST_EMLINK--/* The value of EMSGSIZE. */-#undef CONST_EMSGSIZE--/* The value of EMULTIHOP. */-#undef CONST_EMULTIHOP--/* The value of ENAMETOOLONG. */-#undef CONST_ENAMETOOLONG--/* The value of ENETDOWN. */-#undef CONST_ENETDOWN--/* The value of ENETRESET. */-#undef CONST_ENETRESET--/* The value of ENETUNREACH. */-#undef CONST_ENETUNREACH--/* The value of ENFILE. */-#undef CONST_ENFILE--/* The value of ENOBUFS. */-#undef CONST_ENOBUFS--/* The value of ENOCIGAR. */-#undef CONST_ENOCIGAR--/* The value of ENODATA. */-#undef CONST_ENODATA--/* The value of ENODEV. */-#undef CONST_ENODEV--/* The value of ENOENT. */-#undef CONST_ENOENT--/* The value of ENOEXEC. */-#undef CONST_ENOEXEC--/* The value of ENOLCK. */-#undef CONST_ENOLCK--/* The value of ENOLINK. */-#undef CONST_ENOLINK--/* The value of ENOMEM. */-#undef CONST_ENOMEM--/* The value of ENOMSG. */-#undef CONST_ENOMSG--/* The value of ENONET. */-#undef CONST_ENONET--/* The value of ENOPROTOOPT. */-#undef CONST_ENOPROTOOPT--/* The value of ENOSPC. */-#undef CONST_ENOSPC--/* The value of ENOSR. */-#undef CONST_ENOSR--/* The value of ENOSTR. */-#undef CONST_ENOSTR--/* The value of ENOSYS. */-#undef CONST_ENOSYS--/* The value of ENOTBLK. */-#undef CONST_ENOTBLK--/* The value of ENOTCONN. */-#undef CONST_ENOTCONN--/* The value of ENOTDIR. */-#undef CONST_ENOTDIR--/* The value of ENOTEMPTY. */-#undef CONST_ENOTEMPTY--/* The value of ENOTSOCK. */-#undef CONST_ENOTSOCK--/* The value of ENOTSUP. */-#undef CONST_ENOTSUP--/* The value of ENOTTY. */-#undef CONST_ENOTTY--/* The value of ENXIO. */-#undef CONST_ENXIO--/* The value of EOPNOTSUPP. */-#undef CONST_EOPNOTSUPP--/* The value of EPERM. */-#undef CONST_EPERM--/* The value of EPFNOSUPPORT. */-#undef CONST_EPFNOSUPPORT--/* The value of EPIPE. */-#undef CONST_EPIPE--/* The value of EPROCLIM. */-#undef CONST_EPROCLIM--/* The value of EPROCUNAVAIL. */-#undef CONST_EPROCUNAVAIL--/* The value of EPROGMISMATCH. */-#undef CONST_EPROGMISMATCH--/* The value of EPROGUNAVAIL. */-#undef CONST_EPROGUNAVAIL--/* The value of EPROTO. */-#undef CONST_EPROTO--/* The value of EPROTONOSUPPORT. */-#undef CONST_EPROTONOSUPPORT--/* The value of EPROTOTYPE. */-#undef CONST_EPROTOTYPE--/* The value of ERANGE. */-#undef CONST_ERANGE--/* The value of EREMCHG. */-#undef CONST_EREMCHG--/* The value of EREMOTE. */-#undef CONST_EREMOTE--/* The value of EROFS. */-#undef CONST_EROFS--/* The value of ERPCMISMATCH. */-#undef CONST_ERPCMISMATCH--/* The value of ERREMOTE. */-#undef CONST_ERREMOTE--/* The value of ESHUTDOWN. */-#undef CONST_ESHUTDOWN--/* The value of ESOCKTNOSUPPORT. */-#undef CONST_ESOCKTNOSUPPORT--/* The value of ESPIPE. */-#undef CONST_ESPIPE--/* The value of ESRCH. */-#undef CONST_ESRCH--/* The value of ESRMNT. */-#undef CONST_ESRMNT--/* The value of ESTALE. */-#undef CONST_ESTALE--/* The value of ETIME. */-#undef CONST_ETIME--/* The value of ETIMEDOUT. */-#undef CONST_ETIMEDOUT--/* The value of ETOOMANYREFS. */-#undef CONST_ETOOMANYREFS--/* The value of ETXTBSY. */-#undef CONST_ETXTBSY--/* The value of EUSERS. */-#undef CONST_EUSERS--/* The value of EWOULDBLOCK. */-#undef CONST_EWOULDBLOCK--/* The value of EXDEV. */-#undef CONST_EXDEV--/* The value of O_BINARY. */-#undef CONST_O_BINARY--/* The value of SIGINT. */-#undef CONST_SIGINT--/* Define to 1 if you have the `clock_gettime' function. */-#undef HAVE_CLOCK_GETTIME--/* Define to 1 if you have the <ctype.h> header file. */-#undef HAVE_CTYPE_H--/* Define if you have epoll support. */-#undef HAVE_EPOLL--/* Define to 1 if you have the `epoll_ctl' function. */-#undef HAVE_EPOLL_CTL--/* Define to 1 if you have the <errno.h> header file. */-#undef HAVE_ERRNO_H--/* Define to 1 if you have the `eventfd' function. */-#undef HAVE_EVENTFD--/* Define to 1 if you have the <fcntl.h> header file. */-#undef HAVE_FCNTL_H--/* Define if you have flock support. */-#undef HAVE_FLOCK--/* Define to 1 if you have the `ftruncate' function. */-#undef HAVE_FTRUNCATE--/* Define to 1 if you have the `getclock' function. */-#undef HAVE_GETCLOCK--/* Define to 1 if you have the `getrusage' function. */-#undef HAVE_GETRUSAGE--/* Define to 1 if you have the <inttypes.h> header file. */-#undef HAVE_INTTYPES_H--/* Define to 1 if you have the `iswspace' function. */-#undef HAVE_ISWSPACE--/* Define to 1 if you have the `kevent' function. */-#undef HAVE_KEVENT--/* Define to 1 if you have the `kevent64' function. */-#undef HAVE_KEVENT64--/* Define if you have kqueue support. */-#undef HAVE_KQUEUE--/* Define to 1 if you have the <langinfo.h> header file. */-#undef HAVE_LANGINFO_H--/* Define to 1 if you have libcharset. */-#undef HAVE_LIBCHARSET--/* Define to 1 if you have the `rt' library (-lrt). */-#undef HAVE_LIBRT--/* Define to 1 if you have the <limits.h> header file. */-#undef HAVE_LIMITS_H--/* Define to 1 if the system has the type `long long'. */-#undef HAVE_LONG_LONG--/* Define to 1 if you have the `lstat' function. */-#undef HAVE_LSTAT--/* Define to 1 if you have the <minix/config.h> header file. */-#undef HAVE_MINIX_CONFIG_H--/* Define if you have open file descriptor lock support. */-#undef HAVE_OFD_LOCKING--/* Define if you have poll support. */-#undef HAVE_POLL--/* Define to 1 if you have the <poll.h> header file. */-#undef HAVE_POLL_H--/* Define to 1 if you have the <signal.h> header file. */-#undef HAVE_SIGNAL_H--/* Define to 1 if you have the <stdint.h> header file. */-#undef HAVE_STDINT_H--/* Define to 1 if you have the <stdio.h> header file. */-#undef HAVE_STDIO_H--/* Define to 1 if you have the <stdlib.h> header file. */-#undef HAVE_STDLIB_H--/* Define to 1 if you have the <strings.h> header file. */-#undef HAVE_STRINGS_H--/* Define to 1 if you have the <string.h> header file. */-#undef HAVE_STRING_H--/* Define to 1 if you have the <sys/epoll.h> header file. */-#undef HAVE_SYS_EPOLL_H--/* Define to 1 if you have the <sys/eventfd.h> header file. */-#undef HAVE_SYS_EVENTFD_H--/* Define to 1 if you have the <sys/event.h> header file. */-#undef HAVE_SYS_EVENT_H--/* Define to 1 if you have the <sys/file.h> header file. */-#undef HAVE_SYS_FILE_H--/* Define to 1 if you have the <sys/resource.h> header file. */-#undef HAVE_SYS_RESOURCE_H--/* Define to 1 if you have the <sys/select.h> header file. */-#undef HAVE_SYS_SELECT_H--/* Define to 1 if you have the <sys/socket.h> header file. */-#undef HAVE_SYS_SOCKET_H--/* Define to 1 if you have the <sys/stat.h> header file. */-#undef HAVE_SYS_STAT_H--/* Define to 1 if you have the <sys/syscall.h> header file. */-#undef HAVE_SYS_SYSCALL_H--/* Define to 1 if you have the <sys/timeb.h> header file. */-#undef HAVE_SYS_TIMEB_H--/* Define to 1 if you have the <sys/timers.h> header file. */-#undef HAVE_SYS_TIMERS_H--/* Define to 1 if you have the <sys/times.h> header file. */-#undef HAVE_SYS_TIMES_H--/* Define to 1 if you have the <sys/time.h> header file. */-#undef HAVE_SYS_TIME_H--/* Define to 1 if you have the <sys/types.h> header file. */-#undef HAVE_SYS_TYPES_H--/* Define to 1 if you have the <sys/utsname.h> header file. */-#undef HAVE_SYS_UTSNAME_H--/* Define to 1 if you have the <sys/wait.h> header file. */-#undef HAVE_SYS_WAIT_H--/* Define to 1 if you have the <termios.h> header file. */-#undef HAVE_TERMIOS_H--/* Define to 1 if you have the `times' function. */-#undef HAVE_TIMES--/* Define to 1 if you have the <time.h> header file. */-#undef HAVE_TIME_H--/* Define to 1 if you have the <unistd.h> header file. */-#undef HAVE_UNISTD_H--/* Define to 1 if you have the `unsetenv' function. */-#undef HAVE_UNSETENV--/* Define to 1 if you have the <utime.h> header file. */-#undef HAVE_UTIME_H--/* Define to 1 if you have the <wchar.h> header file. */-#undef HAVE_WCHAR_H--/* Define to 1 if you have the <wctype.h> header file. */-#undef HAVE_WCTYPE_H--/* Define to 1 if you have the <windows.h> header file. */-#undef HAVE_WINDOWS_H--/* Define to 1 if you have the <winsock.h> header file. */-#undef HAVE_WINSOCK_H--/* Define to 1 if you have the `_chsize' function. */-#undef HAVE__CHSIZE--/* Define to Haskell type for blkcnt_t */-#undef HTYPE_BLKCNT_T--/* Define to Haskell type for blksize_t */-#undef HTYPE_BLKSIZE_T--/* Define to Haskell type for bool */-#undef HTYPE_BOOL--/* Define to Haskell type for cc_t */-#undef HTYPE_CC_T--/* Define to Haskell type for char */-#undef HTYPE_CHAR--/* Define to Haskell type for clockid_t */-#undef HTYPE_CLOCKID_T--/* Define to Haskell type for clock_t */-#undef HTYPE_CLOCK_T--/* Define to Haskell type for dev_t */-#undef HTYPE_DEV_T--/* Define to Haskell type for double */-#undef HTYPE_DOUBLE--/* Define to Haskell type for float */-#undef HTYPE_FLOAT--/* Define to Haskell type for fsblkcnt_t */-#undef HTYPE_FSBLKCNT_T--/* Define to Haskell type for fsfilcnt_t */-#undef HTYPE_FSFILCNT_T--/* Define to Haskell type for gid_t */-#undef HTYPE_GID_T--/* Define to Haskell type for id_t */-#undef HTYPE_ID_T--/* Define to Haskell type for ino_t */-#undef HTYPE_INO_T--/* Define to Haskell type for int */-#undef HTYPE_INT--/* Define to Haskell type for intmax_t */-#undef HTYPE_INTMAX_T--/* Define to Haskell type for intptr_t */-#undef HTYPE_INTPTR_T--/* Define to Haskell type for key_t */-#undef HTYPE_KEY_T--/* Define to Haskell type for long */-#undef HTYPE_LONG--/* Define to Haskell type for long long */-#undef HTYPE_LONG_LONG--/* Define to Haskell type for mode_t */-#undef HTYPE_MODE_T--/* Define to Haskell type for nfds_t */-#undef HTYPE_NFDS_T--/* Define to Haskell type for nlink_t */-#undef HTYPE_NLINK_T--/* Define to Haskell type for off_t */-#undef HTYPE_OFF_T--/* Define to Haskell type for pid_t */-#undef HTYPE_PID_T--/* Define to Haskell type for ptrdiff_t */-#undef HTYPE_PTRDIFF_T--/* Define to Haskell type for rlim_t */-#undef HTYPE_RLIM_T--/* Define to Haskell type for short */-#undef HTYPE_SHORT--/* Define to Haskell type for signed char */-#undef HTYPE_SIGNED_CHAR--/* Define to Haskell type for sig_atomic_t */-#undef HTYPE_SIG_ATOMIC_T--/* Define to Haskell type for size_t */-#undef HTYPE_SIZE_T--/* Define to Haskell type for socklen_t */-#undef HTYPE_SOCKLEN_T--/* Define to Haskell type for speed_t */-#undef HTYPE_SPEED_T--/* Define to Haskell type for ssize_t */-#undef HTYPE_SSIZE_T--/* Define to Haskell type for suseconds_t */-#undef HTYPE_SUSECONDS_T--/* Define to Haskell type for tcflag_t */-#undef HTYPE_TCFLAG_T--/* Define to Haskell type for timer_t */-#undef HTYPE_TIMER_T--/* Define to Haskell type for time_t */-#undef HTYPE_TIME_T--/* Define to Haskell type for uid_t */-#undef HTYPE_UID_T--/* Define to Haskell type for uintmax_t */-#undef HTYPE_UINTMAX_T--/* Define to Haskell type for uintptr_t */-#undef HTYPE_UINTPTR_T--/* Define to Haskell type for unsigned char */-#undef HTYPE_UNSIGNED_CHAR--/* Define to Haskell type for unsigned int */-#undef HTYPE_UNSIGNED_INT--/* Define to Haskell type for unsigned long */-#undef HTYPE_UNSIGNED_LONG--/* Define to Haskell type for unsigned long long */-#undef HTYPE_UNSIGNED_LONG_LONG--/* Define to Haskell type for unsigned short */-#undef HTYPE_UNSIGNED_SHORT--/* Define to Haskell type for useconds_t */-#undef HTYPE_USECONDS_T--/* Define to Haskell type for wchar_t */-#undef HTYPE_WCHAR_T--/* Define to the address where bug reports for this package should be sent. */-#undef PACKAGE_BUGREPORT--/* Define to the full name of this package. */-#undef PACKAGE_NAME--/* Define to the full name and version of this package. */-#undef PACKAGE_STRING--/* Define to the one symbol short name of this package. */-#undef PACKAGE_TARNAME--/* Define to the home page for this package. */-#undef PACKAGE_URL--/* Define to the version of this package. */-#undef PACKAGE_VERSION--/* The size of `kev.filter', as computed by sizeof. */-#undef SIZEOF_KEV_FILTER--/* The size of `kev.flags', as computed by sizeof. */-#undef SIZEOF_KEV_FLAGS--/* The size of `struct MD5Context', as computed by sizeof. */-#undef SIZEOF_STRUCT_MD5CONTEXT--/* Define to 1 if all of the C90 standard headers exist (not just the ones-   required in a freestanding environment). This macro is provided for-   backward compatibility; new code need not use it. */-#undef STDC_HEADERS--/* 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 general extensions on macOS.  */-#ifndef _DARWIN_C_SOURCE-# undef _DARWIN_C_SOURCE-#endif-/* Enable general extensions on Solaris.  */-#ifndef __EXTENSIONS__-# undef __EXTENSIONS__-#endif-/* Enable GNU extensions on systems that have them.  */-#ifndef _GNU_SOURCE-# undef _GNU_SOURCE-#endif-/* Enable X/Open compliant socket functions that do not require linking-   with -lxnet on HP-UX 11.11.  */-#ifndef _HPUX_ALT_XOPEN_SOCKET_API-# undef _HPUX_ALT_XOPEN_SOCKET_API-#endif-/* Identify the host operating system as Minix.-   This macro does not affect the system headers' behavior.-   A future release of Autoconf may stop defining this macro.  */-#ifndef _MINIX-# undef _MINIX-#endif-/* Enable general extensions on NetBSD.-   Enable NetBSD compatibility extensions on Minix.  */-#ifndef _NETBSD_SOURCE-# undef _NETBSD_SOURCE-#endif-/* Enable OpenBSD compatibility extensions on NetBSD.-   Oddly enough, this does nothing on OpenBSD.  */-#ifndef _OPENBSD_SOURCE-# undef _OPENBSD_SOURCE-#endif-/* Define to 1 if needed for POSIX-compatible behavior.  */-#ifndef _POSIX_SOURCE-# undef _POSIX_SOURCE-#endif-/* Define to 2 if needed for POSIX-compatible behavior.  */-#ifndef _POSIX_1_SOURCE-# undef _POSIX_1_SOURCE-#endif-/* Enable POSIX-compatible threading on Solaris.  */-#ifndef _POSIX_PTHREAD_SEMANTICS-# undef _POSIX_PTHREAD_SEMANTICS-#endif-/* Enable extensions specified by ISO/IEC TS 18661-5:2014.  */-#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__-# undef __STDC_WANT_IEC_60559_ATTRIBS_EXT__-#endif-/* Enable extensions specified by ISO/IEC TS 18661-1:2014.  */-#ifndef __STDC_WANT_IEC_60559_BFP_EXT__-# undef __STDC_WANT_IEC_60559_BFP_EXT__-#endif-/* Enable extensions specified by ISO/IEC TS 18661-2:2015.  */-#ifndef __STDC_WANT_IEC_60559_DFP_EXT__-# undef __STDC_WANT_IEC_60559_DFP_EXT__-#endif-/* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */-#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__-# undef __STDC_WANT_IEC_60559_FUNCS_EXT__-#endif-/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */-#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__-# undef __STDC_WANT_IEC_60559_TYPES_EXT__-#endif-/* Enable extensions specified by ISO/IEC TR 24731-2:2010.  */-#ifndef __STDC_WANT_LIB_EXT2__-# undef __STDC_WANT_LIB_EXT2__-#endif-/* Enable extensions specified by ISO/IEC 24747:2009.  */-#ifndef __STDC_WANT_MATH_SPEC_FUNCS__-# undef __STDC_WANT_MATH_SPEC_FUNCS__-#endif-/* Enable extensions on HP NonStop.  */-#ifndef _TANDEM_SOURCE-# undef _TANDEM_SOURCE-#endif-/* Enable X/Open extensions.  Define to 500 only if necessary-   to make mbstate_t available.  */-#ifndef _XOPEN_SOURCE-# undef _XOPEN_SOURCE-#endif---/* Number of bits in a file offset, on hosts where this is settable. */-#undef _FILE_OFFSET_BITS--/* Define for large files, on AIX-style hosts. */-#undef _LARGE_FILES
− include/WCsubst.h 
@@ -1,20 +0,0 @@-#pragma once--#include "HsFFI.h"-#include <stdlib.h>--HsInt u_iswupper(HsInt wc);-HsInt u_iswdigit(HsInt wc);-HsInt u_iswalpha(HsInt wc);-HsInt u_iswcntrl(HsInt wc);-HsInt u_iswspace(HsInt wc);-HsInt u_iswprint(HsInt wc);-HsInt u_iswlower(HsInt wc);--HsInt u_iswalnum(HsInt wc);--HsInt u_towlower(HsInt wc);-HsInt u_towupper(HsInt wc);-HsInt u_towtitle(HsInt wc);--HsInt u_gencat(HsInt wc);
− include/consUtils.h 
@@ -1,11 +0,0 @@-/*- * (c) The University of Glasgow, 2000-2002- *- * Win32 Console API helpers.- */-#pragma once--extern int is_console__(int fd);-extern int set_console_buffering__(int fd, int cooked);-extern int set_console_echo__(int fd, int on);-extern int get_console_echo__(int fd);
− include/fs.h 
@@ -1,55 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) Tamar Christina 2018-2019- *- * Windows I/O routines for file opening.- *- * NOTE: Only modify this file in utils/fs/ and rerun configure. Do not edit- *       this file in any other directory as it will be overwritten.- *- * ---------------------------------------------------------------------------*/--#pragma once--#include <stdio.h>--#if !defined(FS_NAMESPACE)-#define FS_NAMESPACE hs-#endif--/* Play some dirty tricks to get CPP to expand correctly.  */-#define FS_FULL(ns, name) __##ns##_##name-#define prefix FS_NAMESPACE-#define FS_L(p, n) FS_FULL(p, n)-#define FS(name) FS_L(prefix, name)--#if defined(_WIN32)-#include <wchar.h>-// N.B. <sys/stat.h> defines some macro rewrites to, e.g., turn _wstat into-// _wstat64i32. We must include it here to ensure tat this rewrite applies to-// both the definition and use sites.-#include <sys/types.h>-#include <sys/stat.h>--wchar_t* FS(create_device_name) (const wchar_t*);-int FS(translate_mode) (const wchar_t*);-int FS(swopen) (const wchar_t* filename, int oflag,-                int shflag, int pmode);-int FS(sopen) (const char* filename, int oflag,-               int shflag, int pmode);-FILE *FS(fwopen) (const wchar_t* filename, const wchar_t* mode);-FILE *FS(fopen) (const char* filename, const char* mode);-int FS(_stat) (const char *path, struct _stat *buffer);-int FS(_stat64) (const char *path, struct __stat64 *buffer);-int FS(_wstat) (const wchar_t *path, struct _stat *buffer);-int FS(_wstat64) (const wchar_t *path, struct __stat64 *buffer);-int FS(_wrename) (const wchar_t *from, const wchar_t *to);-int FS(rename) (const char *from, const char *to);-int FS(unlink) (const char *filename);-int FS(_unlink) (const char *filename);-int FS(_wunlink) (const wchar_t *filename);-int FS(remove) (const char *path);-int FS(_wremove) (const wchar_t *path);-#else-FILE *FS(fopen) (const char* filename, const char* mode);-#endif
− include/ieee-flpt.h 
@@ -1,35 +0,0 @@-/* this file is #included into both C (.c and .hc) and Haskell files */--    /* IEEE format floating-point */-#define IEEE_FLOATING_POINT 1--   /* Radix of exponent representation */-#if !defined(FLT_RADIX)-# define FLT_RADIX 2-#endif--   /* Number of base-FLT_RADIX digits in the significand of a float */-#if !defined(FLT_MANT_DIG)-# define FLT_MANT_DIG 24-#endif-   /* Minimum int x such that FLT_RADIX**(x-1) is a normalised float */-#if !defined(FLT_MIN_EXP)-#  define FLT_MIN_EXP (-125)-#endif-   /* Maximum int x such that FLT_RADIX**(x-1) is a representable float */-#if !defined(FLT_MAX_EXP)-# define FLT_MAX_EXP 128-#endif--   /* Number of base-FLT_RADIX digits in the significand of a double */-#if !defined(DBL_MANT_DIG)-# define DBL_MANT_DIG 53-#endif-   /* Minimum int x such that FLT_RADIX**(x-1) is a normalised double */-#if !defined(DBL_MIN_EXP)-#  define DBL_MIN_EXP (-1021)-#endif-   /* Maximum int x such that FLT_RADIX**(x-1) is a representable double */-#if !defined(DBL_MAX_EXP)-# define DBL_MAX_EXP 1024-#endif
− include/md5.h 
@@ -1,15 +0,0 @@-/* MD5 message digest */-#pragma once--#include <stdint.h>--struct MD5Context {-	uint32_t buf[4];-	uint32_t bytes[2];-	uint32_t in[16];-};--void __hsbase_MD5Init(struct MD5Context *context);-void __hsbase_MD5Update(struct MD5Context *context, uint8_t const *buf, int len);-void __hsbase_MD5Final(uint8_t digest[16], struct MD5Context *context);-void __hsbase_MD5Transform(uint32_t buf[4], uint32_t const in[16]);
− include/winio_structs.h 
@@ -1,40 +0,0 @@-/*- * (c) Tamar Christina, 2019.- *- * Structures supporting the IOCP based I/O Manager or Windows.- */--#include <Windows.h>-#include <stdint.h>--#if defined(_WIN64)-#  define ALIGNMENT __attribute__ ((aligned (8)))-#elif defined(_WIN32)-#  define ALIGNMENT __attribute__ ((aligned (8)))-#else-#  error "unknown environment, can't determine alignment"-#endif--/* Completion data structure.  Must be kept in sync with that in-   GHC.Event.Windows or horrible things happen.  */-typedef struct _CompletionData {-  /* The Handle to the object for which the I/O operation is in progress.  */-  HWND cdHandle;-  /* Handle to the callback routine to call to notify that an operation has-     finished.  This value is opaque as it shouldn't be accessible-     outside the Haskell world.  */-  uintptr_t cdCallback;-} CompletionData, *LPCompletionData;--/* The Windows API Requires an OVERLAPPED struct for asynchronous access,-   however if we pad the structure we can give extra book keeping information-   without needing to look these up later.  Do not modify this struct unless-   you know what you're doing.   */-typedef struct _HASKELL_OVERLAPPED {-  /* Windows OVERLAPPED structure.  NOTE: MUST BE FIRST element.  */-  OVERLAPPED hoOverlapped;-  /* Pointer to additional payload in Haskell land.  This will contain a-     foreign pointer.  We only use atomic operations to access this field in-     order to correctly handle multiple threads using it.  */-  LPCompletionData hoData ALIGNMENT;-} HASKELL_OVERLAPPED;
− install-sh 
@@ -1,527 +0,0 @@-#!/bin/sh-# install - install a program, script, or datafile--scriptversion=2011-11-20.07; # UTC--# This originates from X11R5 (mit/util/scripts/install.sh), which was-# later released in X11R6 (xc/config/util/install.sh) with the-# following copyright and license.-#-# Copyright (C) 1994 X Consortium-#-# Permission is hereby granted, free of charge, to any person obtaining a copy-# of this software and associated documentation files (the "Software"), to-# deal in the Software without restriction, including without limitation the-# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or-# sell copies of the Software, and to permit persons to whom the Software is-# furnished to do so, subject to the following conditions:-#-# The above copyright notice and this permission notice shall be included in-# all copies or substantial portions of the Software.-#-# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE-# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN-# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC--# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.-#-# Except as contained in this notice, the name of the X Consortium shall not-# be used in advertising or otherwise to promote the sale, use or other deal--# ings in this Software without prior written authorization from the X Consor--# tium.-#-#-# FSF changes to this file are in the public domain.-#-# Calling this script install-sh is preferred over install.sh, to prevent-# 'make' implicit rules from creating a file called install from it-# when there is no Makefile.-#-# This script is compatible with the BSD install script, but was written-# from scratch.--nl='-'-IFS=" ""	$nl"--# set DOITPROG to echo to test this script--# Don't use :- since 4.3BSD and earlier shells don't like it.-doit=${DOITPROG-}-if test -z "$doit"; then-  doit_exec=exec-else-  doit_exec=$doit-fi--# Put in absolute file names if you don't have them in your path;-# or use environment vars.--chgrpprog=${CHGRPPROG-chgrp}-chmodprog=${CHMODPROG-chmod}-chownprog=${CHOWNPROG-chown}-cmpprog=${CMPPROG-cmp}-cpprog=${CPPROG-cp}-mkdirprog=${MKDIRPROG-mkdir}-mvprog=${MVPROG-mv}-rmprog=${RMPROG-rm}-stripprog=${STRIPPROG-strip}--posix_glob='?'-initialize_posix_glob='-  test "$posix_glob" != "?" || {-    if (set -f) 2>/dev/null; then-      posix_glob=-    else-      posix_glob=:-    fi-  }-'--posix_mkdir=--# Desired mode of installed file.-mode=0755--chgrpcmd=-chmodcmd=$chmodprog-chowncmd=-mvcmd=$mvprog-rmcmd="$rmprog -f"-stripcmd=--src=-dst=-dir_arg=-dst_arg=--copy_on_change=false-no_target_directory=--usage="\-Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE-   or: $0 [OPTION]... SRCFILES... DIRECTORY-   or: $0 [OPTION]... -t DIRECTORY SRCFILES...-   or: $0 [OPTION]... -d DIRECTORIES...--In the 1st form, copy SRCFILE to DSTFILE.-In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.-In the 4th, create DIRECTORIES.--Options:-     --help     display this help and exit.-     --version  display version info and exit.--  -c            (ignored)-  -C            install only if different (preserve the last data modification time)-  -d            create directories instead of installing files.-  -g GROUP      $chgrpprog installed files to GROUP.-  -m MODE       $chmodprog installed files to MODE.-  -o USER       $chownprog installed files to USER.-  -s            $stripprog installed files.-  -t DIRECTORY  install into DIRECTORY.-  -T            report an error if DSTFILE is a directory.--Environment variables override the default commands:-  CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG-  RMPROG STRIPPROG-"--while test $# -ne 0; do-  case $1 in-    -c) ;;--    -C) copy_on_change=true;;--    -d) dir_arg=true;;--    -g) chgrpcmd="$chgrpprog $2"-	shift;;--    --help) echo "$usage"; exit $?;;--    -m) mode=$2-	case $mode in-	  *' '* | *'	'* | *'-'*	  | *'*'* | *'?'* | *'['*)-	    echo "$0: invalid mode: $mode" >&2-	    exit 1;;-	esac-	shift;;--    -o) chowncmd="$chownprog $2"-	shift;;--    -s) stripcmd=$stripprog;;--    -t) dst_arg=$2-	# Protect names problematic for 'test' and other utilities.-	case $dst_arg in-	  -* | [=\(\)!]) dst_arg=./$dst_arg;;-	esac-	shift;;--    -T) no_target_directory=true;;--    --version) echo "$0 $scriptversion"; exit $?;;--    --)	shift-	break;;--    -*)	echo "$0: invalid option: $1" >&2-	exit 1;;--    *)  break;;-  esac-  shift-done--if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then-  # When -d is used, all remaining arguments are directories to create.-  # When -t is used, the destination is already specified.-  # Otherwise, the last argument is the destination.  Remove it from $@.-  for arg-  do-    if test -n "$dst_arg"; then-      # $@ is not empty: it contains at least $arg.-      set fnord "$@" "$dst_arg"-      shift # fnord-    fi-    shift # arg-    dst_arg=$arg-    # Protect names problematic for 'test' and other utilities.-    case $dst_arg in-      -* | [=\(\)!]) dst_arg=./$dst_arg;;-    esac-  done-fi--if test $# -eq 0; then-  if test -z "$dir_arg"; then-    echo "$0: no input file specified." >&2-    exit 1-  fi-  # It's OK to call 'install-sh -d' without argument.-  # This can happen when creating conditional directories.-  exit 0-fi--if test -z "$dir_arg"; then-  do_exit='(exit $ret); exit $ret'-  trap "ret=129; $do_exit" 1-  trap "ret=130; $do_exit" 2-  trap "ret=141; $do_exit" 13-  trap "ret=143; $do_exit" 15--  # Set umask so as not to create temps with too-generous modes.-  # However, 'strip' requires both read and write access to temps.-  case $mode in-    # Optimize common cases.-    *644) cp_umask=133;;-    *755) cp_umask=22;;--    *[0-7])-      if test -z "$stripcmd"; then-	u_plus_rw=-      else-	u_plus_rw='% 200'-      fi-      cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;-    *)-      if test -z "$stripcmd"; then-	u_plus_rw=-      else-	u_plus_rw=,u+rw-      fi-      cp_umask=$mode$u_plus_rw;;-  esac-fi--for src-do-  # Protect names problematic for 'test' and other utilities.-  case $src in-    -* | [=\(\)!]) src=./$src;;-  esac--  if test -n "$dir_arg"; then-    dst=$src-    dstdir=$dst-    test -d "$dstdir"-    dstdir_status=$?-  else--    # Waiting for this to be detected by the "$cpprog $src $dsttmp" command-    # might cause directories to be created, which would be especially bad-    # if $src (and thus $dsttmp) contains '*'.-    if test ! -f "$src" && test ! -d "$src"; then-      echo "$0: $src does not exist." >&2-      exit 1-    fi--    if test -z "$dst_arg"; then-      echo "$0: no destination specified." >&2-      exit 1-    fi-    dst=$dst_arg--    # If destination is a directory, append the input filename; won't work-    # if double slashes aren't ignored.-    if test -d "$dst"; then-      if test -n "$no_target_directory"; then-	echo "$0: $dst_arg: Is a directory" >&2-	exit 1-      fi-      dstdir=$dst-      dst=$dstdir/`basename "$src"`-      dstdir_status=0-    else-      # Prefer dirname, but fall back on a substitute if dirname fails.-      dstdir=`-	(dirname "$dst") 2>/dev/null ||-	expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \-	     X"$dst" : 'X\(//\)[^/]' \| \-	     X"$dst" : 'X\(//\)$' \| \-	     X"$dst" : 'X\(/\)' \| . 2>/dev/null ||-	echo X"$dst" |-	    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{-		   s//\1/-		   q-		 }-		 /^X\(\/\/\)[^/].*/{-		   s//\1/-		   q-		 }-		 /^X\(\/\/\)$/{-		   s//\1/-		   q-		 }-		 /^X\(\/\).*/{-		   s//\1/-		   q-		 }-		 s/.*/./; q'-      `--      test -d "$dstdir"-      dstdir_status=$?-    fi-  fi--  obsolete_mkdir_used=false--  if test $dstdir_status != 0; then-    case $posix_mkdir in-      '')-	# Create intermediate dirs using mode 755 as modified by the umask.-	# This is like FreeBSD 'install' as of 1997-10-28.-	umask=`umask`-	case $stripcmd.$umask in-	  # Optimize common cases.-	  *[2367][2367]) mkdir_umask=$umask;;-	  .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;;--	  *[0-7])-	    mkdir_umask=`expr $umask + 22 \-	      - $umask % 100 % 40 + $umask % 20 \-	      - $umask % 10 % 4 + $umask % 2-	    `;;-	  *) mkdir_umask=$umask,go-w;;-	esac--	# With -d, create the new directory with the user-specified mode.-	# Otherwise, rely on $mkdir_umask.-	if test -n "$dir_arg"; then-	  mkdir_mode=-m$mode-	else-	  mkdir_mode=-	fi--	posix_mkdir=false-	case $umask in-	  *[123567][0-7][0-7])-	    # POSIX mkdir -p sets u+wx bits regardless of umask, which-	    # is incompatible with FreeBSD 'install' when (umask & 300) != 0.-	    ;;-	  *)-	    tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$-	    trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0--	    if (umask $mkdir_umask &&-		exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1-	    then-	      if test -z "$dir_arg" || {-		   # Check for POSIX incompatibilities with -m.-		   # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or-		   # other-writable bit of parent directory when it shouldn't.-		   # FreeBSD 6.1 mkdir -m -p sets mode of existing directory.-		   ls_ld_tmpdir=`ls -ld "$tmpdir"`-		   case $ls_ld_tmpdir in-		     d????-?r-*) different_mode=700;;-		     d????-?--*) different_mode=755;;-		     *) false;;-		   esac &&-		   $mkdirprog -m$different_mode -p -- "$tmpdir" && {-		     ls_ld_tmpdir_1=`ls -ld "$tmpdir"`-		     test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"-		   }-		 }-	      then posix_mkdir=:-	      fi-	      rmdir "$tmpdir/d" "$tmpdir"-	    else-	      # Remove any dirs left behind by ancient mkdir implementations.-	      rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null-	    fi-	    trap '' 0;;-	esac;;-    esac--    if-      $posix_mkdir && (-	umask $mkdir_umask &&-	$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"-      )-    then :-    else--      # The umask is ridiculous, or mkdir does not conform to POSIX,-      # or it failed possibly due to a race condition.  Create the-      # directory the slow way, step by step, checking for races as we go.--      case $dstdir in-	/*) prefix='/';;-	[-=\(\)!]*) prefix='./';;-	*)  prefix='';;-      esac--      eval "$initialize_posix_glob"--      oIFS=$IFS-      IFS=/-      $posix_glob set -f-      set fnord $dstdir-      shift-      $posix_glob set +f-      IFS=$oIFS--      prefixes=--      for d-      do-	test X"$d" = X && continue--	prefix=$prefix$d-	if test -d "$prefix"; then-	  prefixes=-	else-	  if $posix_mkdir; then-	    (umask=$mkdir_umask &&-	     $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break-	    # Don't fail if two instances are running concurrently.-	    test -d "$prefix" || exit 1-	  else-	    case $prefix in-	      *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;-	      *) qprefix=$prefix;;-	    esac-	    prefixes="$prefixes '$qprefix'"-	  fi-	fi-	prefix=$prefix/-      done--      if test -n "$prefixes"; then-	# Don't fail if two instances are running concurrently.-	(umask $mkdir_umask &&-	 eval "\$doit_exec \$mkdirprog $prefixes") ||-	  test -d "$dstdir" || exit 1-	obsolete_mkdir_used=true-      fi-    fi-  fi--  if test -n "$dir_arg"; then-    { test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&-    { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&-    { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||-      test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1-  else--    # Make a couple of temp file names in the proper directory.-    dsttmp=$dstdir/_inst.$$_-    rmtmp=$dstdir/_rm.$$_--    # Trap to clean up those temp files at exit.-    trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0--    # Copy the file name to the temp name.-    (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") &&--    # and set any options; do chmod last to preserve setuid bits.-    #-    # If any of these fail, we abort the whole thing.  If we want to-    # ignore errors from any of these, just make sure not to ignore-    # errors from the above "$doit $cpprog $src $dsttmp" command.-    #-    { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&-    { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&-    { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&-    { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&--    # If -C, don't bother to copy if it wouldn't change the file.-    if $copy_on_change &&-       old=`LC_ALL=C ls -dlL "$dst"	2>/dev/null` &&-       new=`LC_ALL=C ls -dlL "$dsttmp"	2>/dev/null` &&--       eval "$initialize_posix_glob" &&-       $posix_glob set -f &&-       set X $old && old=:$2:$4:$5:$6 &&-       set X $new && new=:$2:$4:$5:$6 &&-       $posix_glob set +f &&--       test "$old" = "$new" &&-       $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1-    then-      rm -f "$dsttmp"-    else-      # Rename the file to the real destination.-      $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||--      # The rename failed, perhaps because mv can't rename something else-      # to itself, or perhaps because mv is so ancient that it does not-      # support -f.-      {-	# Now remove or move aside any old file at destination location.-	# We try this two ways since rm can't unlink itself on some-	# systems and the destination file might be busy for other-	# reasons.  In this case, the final cleanup might fail but the new-	# file should still install successfully.-	{-	  test ! -f "$dst" ||-	  $doit $rmcmd -f "$dst" 2>/dev/null ||-	  { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&-	    { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }-	  } ||-	  { echo "$0: cannot unlink or rename $dst" >&2-	    (exit 1); exit 1-	  }-	} &&--	# Now rename the file to the real destination.-	$doit $mvcmd "$dsttmp" "$dst"-      }-    fi || exit 1--    trap '' 0-  fi-done--# Local variables:-# eval: (add-hook 'write-file-hooks 'time-stamp)-# time-stamp-start: "scriptversion="-# time-stamp-format: "%:y-%02m-%02d.%02H"-# time-stamp-time-zone: "UTC"-# time-stamp-end: "; # UTC"-# End:
+ src/Control/Applicative.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Applicative+-- Copyright   :  Conor McBride and Ross Paterson 2005+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- This module describes a structure intermediate between a functor and+-- a monad (technically, a strong lax monoidal functor).  Compared with+-- monads, this interface lacks the full power of the binding operation+-- '>>=', but+--+-- * it has more instances.+--+-- * it is sufficient for many uses, e.g. context-free parsing, or the+--   'Data.Traversable.Traversable' class.+--+-- * instances can perform analysis of computations before they are+--   executed, and thus produce shared optimizations.+--+-- This interface was introduced for parsers by Niklas R&#xF6;jemo, because+-- it admits more sharing than the monadic interface.  The names here are+-- mostly based on parsing work by Doaitse Swierstra.+--+-- For more details, see+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,+-- by Conor McBride and Ross Paterson.++module Control.Applicative (+    -- * Applicative functors+    Applicative(..),+    -- * Alternatives+    Alternative(..),+    -- * Instances+    Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),+    -- * Utility functions+    (<$>), (<$), (<**>),+    liftA, liftA3,+    optional,+    asum,+    ) where++import GHC.Internal.Control.Category hiding ((.), id)+import GHC.Internal.Control.Arrow+import GHC.Internal.Data.Maybe+import GHC.Internal.Data.Tuple+import GHC.Internal.Data.Foldable (asum)+import GHC.Internal.Data.Functor ((<$>))+import GHC.Internal.Data.Functor.Const (Const(..))+import GHC.Internal.Data.Typeable (Typeable)+import GHC.Internal.Data.Data (Data)++import GHC.Internal.Base+import GHC.Internal.Functor.ZipList (ZipList(..))+import GHC.Generics++-- $setup+-- >>> import Prelude++newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }+                         deriving ( Generic  -- ^ @since 4.7.0.0+                                  , Generic1 -- ^ @since 4.7.0.0+                                  , Monad    -- ^ @since 4.7.0.0+                                  )++-- | @since 2.01+instance Monad m => Functor (WrappedMonad m) where+    fmap f (WrapMonad v) = WrapMonad (liftM f v)++-- | @since 2.01+instance Monad m => Applicative (WrappedMonad m) where+    pure = WrapMonad . pure+    WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)+    liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y)++-- | @since 2.01+instance MonadPlus m => Alternative (WrappedMonad m) where+    empty = WrapMonad mzero+    WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)++-- | @since 4.14.0.0+deriving instance (Typeable (m :: Type -> Type), Typeable a, Data (m a))+         => Data (WrappedMonad m a)++newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }+                           deriving ( Generic  -- ^ @since 4.7.0.0+                                    , Generic1 -- ^ @since 4.7.0.0+                                    )++-- | @since 2.01+instance Arrow a => Functor (WrappedArrow a b) where+    fmap f (WrapArrow a) = WrapArrow (a >>> arr f)++-- | @since 2.01+instance Arrow a => Applicative (WrappedArrow a b) where+    pure x = WrapArrow (arr (const x))+    liftA2 f (WrapArrow u) (WrapArrow v) =+      WrapArrow (u &&& v >>> arr (uncurry f))++-- | @since 2.01+instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where+    empty = WrapArrow zeroArrow+    WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)++-- | @since 4.14.0.0+deriving instance (Typeable (a :: Type -> Type -> Type), Typeable b, Typeable c,+                   Data (a b c))+         => Data (WrappedArrow a b c)++-- extra functions++-- | One or none.+--+-- It is useful for modelling any computation that is allowed to fail.+--+-- ==== __Examples__+--+-- Using the 'Alternative' instance of "Control.Monad.Except", the following functions:+--+-- >>> import Control.Monad.Except+--+-- >>> canFail = throwError "it failed" :: Except String Int+-- >>> final = return 42                :: Except String Int+--+-- Can be combined by allowing the first function to fail:+--+-- >>> runExcept $ canFail *> final+-- Left "it failed"+--+-- >>> runExcept $ optional canFail *> final+-- Right 42++optional :: Alternative f => f a -> f (Maybe a)+optional v = Just <$> v <|> pure Nothing
+ src/Control/Arrow.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Arrow+-- Copyright   :  (c) Ross Paterson 2002+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Basic arrow definitions, based on+--+--  * /Generalising Monads to Arrows/, by John Hughes,+--    /Science of Computer Programming/ 37, pp67-111, May 2000.+--+-- plus a couple of definitions ('returnA' and 'loop') from+--+--  * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,+--    Firenze, Italy, pp229-240.+--+-- These papers and more information on arrows can be found at+-- <http://www.haskell.org/arrows/>.++module Control.Arrow+    (-- *  Arrows+     Arrow(..),+     Kleisli(..),+     -- **  Derived combinators+     returnA,+     (^>>),+     (>>^),+     (>>>),+     (<<<),+     -- **  Right-to-left variants+     (<<^),+     (^<<),+     -- *  Monoid operations+     ArrowZero(..),+     ArrowPlus(..),+     -- *  Conditionals+     ArrowChoice(..),+     -- *  Arrow application+     ArrowApply(..),+     ArrowMonad(..),+     leftApp,+     -- *  Feedback+     ArrowLoop(..)+     ) where++import GHC.Internal.Control.Arrow
+ src/Control/Category.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Control.Category+-- Copyright   :  (c) Ashley Yakeley 2007+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  ashley@semantic.org+-- Stability   :  stable+-- Portability :  portable+--++module Control.Category+  ( -- * Class+    Category(..)++    -- * Combinators+  , (<<<)+  , (>>>)++  -- $namingConflicts+  ) where++import GHC.Internal.Control.Category++-- $namingConflicts+--+-- == A note on naming conflicts+--+-- The methods from 'Category' conflict with 'Prelude.id' and 'Prelude..' from the+-- prelude; you will likely want to either import this module qualified, or hide the+-- prelude functions:+--+-- @+-- import "Prelude" hiding (id, (.))+-- @
+ src/Control/Concurrent.hs view
@@ -0,0 +1,534 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP+           , MagicHash+           , UnboxedTuples+           , ScopedTypeVariables+           , RankNTypes+  #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+-- kludge for the Control.Concurrent.QSem, Control.Concurrent.QSemN+-- and Control.Concurrent.SampleVar imports.++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (concurrency)+--+-- A common interface to a collection of useful concurrency+-- abstractions.+--+-----------------------------------------------------------------------------++module Control.Concurrent (+        -- * Concurrent Haskell++        -- $conc_intro++        -- * Basic concurrency operations++        ThreadId,+        myThreadId,++        forkIO,+        forkFinally,+        forkIOWithUnmask,+        killThread,+        throwTo,++        -- ** Threads with affinity+        forkOn,+        forkOnWithUnmask,+        getNumCapabilities,+        setNumCapabilities,+        threadCapability,++        -- * Scheduling++        -- $conc_scheduling+        yield,++        -- ** Blocking++        -- $blocking++        -- ** Waiting+        threadDelay,+        threadWaitRead,+        threadWaitWrite,+        threadWaitReadSTM,+        threadWaitWriteSTM,++        -- * Communication abstractions++        module GHC.Internal.Control.Concurrent.MVar,+        module Control.Concurrent.Chan,+        module Control.Concurrent.QSem,+        module Control.Concurrent.QSemN,++        -- * Bound Threads+        -- $boundthreads+        rtsSupportsBoundThreads,+        forkOS,+        forkOSWithUnmask,+        isCurrentThreadBound,+        runInBoundThread,+        runInUnboundThread,++        -- * Weak references to ThreadIds+        mkWeakThreadId,++        -- * GHC's implementation of concurrency++        -- |This section describes features specific to GHC's+        -- implementation of Concurrent Haskell.++        -- ** Haskell threads and Operating System threads++        -- $osthreads++        -- ** Terminating the program++        -- $termination++        -- ** Pre-emption++        -- $preemption++        -- ** Deadlock++        -- $deadlock++    ) where++import Prelude+import GHC.Internal.Control.Exception.Base as Exception++import GHC.Internal.Conc.Bound+import GHC.Conc hiding (threadWaitRead, threadWaitWrite,+                        threadWaitReadSTM, threadWaitWriteSTM)++import GHC.Internal.System.Posix.Types ( Fd )++#if defined(mingw32_HOST_OS)+import GHC.Internal.Foreign.C.Error+import GHC.Internal.Foreign.C.Types+import GHC.Internal.System.IO+import GHC.Internal.Data.Functor ( void )+import GHC.Internal.Int ( Int64 )+#else+import qualified GHC.Internal.Conc.IO as Conc+#endif++import GHC.Internal.Control.Concurrent.MVar+import Control.Concurrent.Chan+import Control.Concurrent.QSem+import Control.Concurrent.QSemN++{- $conc_intro++The concurrency extension for Haskell is described in the paper+/Concurrent Haskell/+<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.++Concurrency is \"lightweight\", which means that both thread creation+and context switching overheads are extremely low.  Scheduling of+Haskell threads is done internally in the Haskell runtime system, and+doesn't make use of any operating system-supplied thread packages.++However, if you want to interact with a foreign library that expects your+program to use the operating system-supplied thread package, you can do so+by using 'forkOS' instead of 'forkIO'.++Haskell threads can communicate via 'MVar's, a kind of synchronised+mutable variable (see "Control.Concurrent.MVar").  Several common+concurrency abstractions can be built from 'MVar's, and these are+provided by the "Control.Concurrent" module.+In GHC, threads may also communicate via exceptions.+-}++{- $conc_scheduling++    Scheduling may be either pre-emptive or co-operative,+    depending on the implementation of Concurrent Haskell (see below+    for information related to specific compilers).  In a co-operative+    system, context switches only occur when you use one of the+    primitives defined in this module.  This means that programs such+    as:+++>   main = forkIO (write 'a') >> write 'b'+>     where write c = putChar c >> write c++    will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,+    instead of some random interleaving of @a@s and @b@s.  In+    practice, cooperative multitasking is sufficient for writing+    simple graphical user interfaces.+-}++{- $blocking+Different Haskell implementations have different characteristics with+regard to which operations block /all/ threads.++Using GHC without the @-threaded@ option, all foreign calls will block+all other Haskell threads in the system, although I\/O operations will+not.  With the @-threaded@ option, only foreign calls with the @unsafe@+attribute will block all other threads.++-}++-- | 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.+--+-- > forkFinally action and_then =+-- >   mask $ \restore ->+-- >     forkIO $ try (restore action) >>= and_then+--+-- This function is useful for informing the parent when a child+-- terminates, for example.+--+-- @since 4.6.0.0+forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action and_then =+  mask $ \restore ->+    forkIO $ try (restore action) >>= and_then++-- ---------------------------------------------------------------------------+-- Bound Threads++{- $boundthreads+   #boundthreads#++Support for multiple operating system threads and bound threads as described+below is currently only available in the GHC runtime system if you use the+/-threaded/ option when linking.++Other Haskell systems do not currently support multiple operating system threads.++A bound thread is a haskell thread that is /bound/ to an operating system+thread. While the bound thread is still scheduled by the Haskell run-time+system, the operating system thread takes care of all the foreign calls made+by the bound thread.++To a foreign library, the bound thread will look exactly like an ordinary+operating system thread created using OS functions like @pthread_create@+or @CreateThread@.++Bound threads can be created using the 'forkOS' function below. All foreign+exported functions are run in a bound thread (bound to the OS thread that+called the function). Also, the @main@ action of every Haskell program is+run in a bound thread.++Why do we need this? Because if a foreign library is called from a thread+created using 'forkIO', it won't have access to any /thread-local state/ -+state variables that have specific values for each OS thread+(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some+libraries (OpenGL, for example) will not work from a thread created using+'forkIO'. They work fine in threads created using 'forkOS' or when called+from @main@ or from a @foreign export@.++In terms of performance, 'forkOS' (aka bound) threads are much more+expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'+thread is tied to a particular OS thread, whereas a 'forkIO' thread+can be run by any OS thread.  Context-switching between a 'forkOS'+thread and a 'forkIO' thread is many times more expensive than between+two 'forkIO' threads.++Note in particular that the main program thread (the thread running+@Main.main@) is always a bound thread, so for good concurrency+performance you should ensure that the main thread is not doing+repeated communication with other threads in the system.  Typically+this means forking subthreads to do the work using 'forkIO', and+waiting for the results in the main thread.++-}++-- ---------------------------------------------------------------------------+-- threadWaitRead/threadWaitWrite++-- | Block the current thread until data is available to read on the+-- given file descriptor (GHC only).+--+-- This will throw an 'IOError' if the file descriptor was closed+-- while this thread was blocked.  To safely close a file descriptor+-- that has been used with 'threadWaitRead', use+-- 'GHC.Conc.closeFdWith'.+threadWaitRead :: Fd -> IO ()+threadWaitRead fd+#if defined(mingw32_HOST_OS)+  -- we have no IO manager implementing threadWaitRead on Windows.+  -- fdReady does the right thing, but we have to call it in a+  -- separate thread, otherwise threadWaitRead won't be interruptible,+  -- and this only works with -threaded.+  | threaded  = withThread "threadWaitRead worker" (waitFd fd False)+  | otherwise = case fd of+                  0 -> do _ <- hWaitForInput stdin (-1)+                          return ()+                        -- hWaitForInput does work properly, but we can only+                        -- do this for stdin since we know its FD.+                  _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use GHC.System.IO.hWaitForInput"+#else+  = Conc.threadWaitRead fd+#endif++-- | Block the current thread until data can be written to the+-- given file descriptor (GHC only).+--+-- This will throw an 'IOError' if the file descriptor was closed+-- while this thread was blocked.  To safely close a file descriptor+-- that has been used with 'threadWaitWrite', use+-- 'GHC.Conc.closeFdWith'.+threadWaitWrite :: Fd -> IO ()+threadWaitWrite fd+#if defined(mingw32_HOST_OS)+  | threaded  = withThread "threadWaitWrite worker" (waitFd fd True)+  | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows"+#else+  = Conc.threadWaitWrite fd+#endif++-- | Returns an STM action that can be used to wait for data+-- to read from a file descriptor. The second returned value+-- is an IO action that can be used to deregister interest+-- in the file descriptor.+--+-- @since 4.7.0.0+threadWaitReadSTM :: Fd -> IO (STM (), IO ())+threadWaitReadSTM fd+#if defined(mingw32_HOST_OS)+  | threaded = do v <- newTVarIO Nothing+                  mask_ $ void $ forkIO $ do+                    tid <- myThreadId+                    labelThread tid "threadWaitReadSTM worker"+                    result <- try (waitFd fd False)+                    atomically (writeTVar v $ Just result)+                  let waitAction = do result <- readTVar v+                                      case result of+                                        Nothing         -> retry+                                        Just (Right ()) -> return ()+                                        Just (Left e)   -> throwSTM (e :: IOException)+                  let killAction = return ()+                  return (waitAction, killAction)+  | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows"+#else+  = Conc.threadWaitReadSTM fd+#endif++-- | Returns an STM action that can be used to wait until data+-- can be written to a file descriptor. The second returned value+-- is an IO action that can be used to deregister interest+-- in the file descriptor.+--+-- @since 4.7.0.0+threadWaitWriteSTM :: Fd -> IO (STM (), IO ())+threadWaitWriteSTM fd+#if defined(mingw32_HOST_OS)+  | threaded = do v <- newTVarIO Nothing+                  mask_ $ void $ forkIO $ do+                    tid <- myThreadId+                    labelThread tid "threadWaitWriteSTM worker"+                    result <- try (waitFd fd True)+                    atomically (writeTVar v $ Just result)+                  let waitAction = do result <- readTVar v+                                      case result of+                                        Nothing         -> retry+                                        Just (Right ()) -> return ()+                                        Just (Left e)   -> throwSTM (e :: IOException)+                  let killAction = return ()+                  return (waitAction, killAction)+  | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows"+#else+  = Conc.threadWaitWriteSTM fd+#endif++#if defined(mingw32_HOST_OS)+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool++withThread :: String -> IO a -> IO a+withThread label io = do+  m <- newEmptyMVar+  _ <- mask_ $ forkIO $ do+    tid <- myThreadId+    labelThread tid label+    result <- try io+    putMVar m result+  x <- takeMVar m+  case x of+    Right a -> return a+    Left e  -> throwIO (e :: IOException)++waitFd :: Fd -> Bool -> IO ()+waitFd fd write = do+   throwErrnoIfMinus1_ "fdReady" $+        fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0++foreign import ccall safe "fdReady"+  fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt+#endif++-- ---------------------------------------------------------------------------+-- More docs++{- $osthreads++      #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and+      are managed entirely by the GHC runtime.  Typically Haskell+      threads are an order of magnitude or two more efficient (in+      terms of both time and space) than operating system threads.++      The downside of having lightweight threads is that only one can+      run at a time, so if one thread blocks in a foreign call, for+      example, the other threads cannot continue.  The GHC runtime+      works around this by making use of full OS threads where+      necessary.  When the program is built with the @-threaded@+      option (to link against the multithreaded version of the+      runtime), a thread making a @safe@ foreign call will not block+      the other threads in the system; another OS thread will take+      over running Haskell threads until the original call returns.+      The runtime maintains a pool of these /worker/ threads so that+      multiple Haskell threads can be involved in external calls+      simultaneously.++      The "System.IO" module manages multiplexing in its own way.  On+      Windows systems it uses @safe@ foreign calls to ensure that+      threads doing I\/O operations don't block the whole runtime,+      whereas on Unix systems all the currently blocked I\/O requests+      are managed by a single thread (the /IO manager thread/) using+      a mechanism such as @epoll@ or @kqueue@, depending on what is+      provided by the host operating system.++      The runtime will run a Haskell thread using any of the available+      worker OS threads.  If you need control over which particular OS+      thread is used to run a given Haskell thread, perhaps because+      you need to call a foreign library that uses OS-thread-local+      state, then you need bound threads (see "Control.Concurrent#boundthreads").++      If you don't use the @-threaded@ option, then the runtime does+      not make use of multiple OS threads.  Foreign calls will block+      all other running Haskell threads until the call returns.  The+      "System.IO" module still does multiplexing, so there can be multiple+      threads doing I\/O, and this is handled internally by the runtime using+      @select@.+-}++{- $termination++      In a standalone GHC program, only the main thread is+      required to terminate in order for the process to terminate.+      Thus all other forked threads will simply terminate at the same+      time as the main thread (the terminology for this kind of+      behaviour is \"daemonic threads\").++      If you want the program to wait for child threads to+      finish before exiting, you need to program this yourself.  A+      simple mechanism is to have each child thread write to an+      'MVar' when it completes, and have the main+      thread wait on all the 'MVar's before+      exiting:++>   myForkIO :: IO () -> IO (MVar ())+>   myForkIO io = do+>     mvar <- newEmptyMVar+>     forkFinally io (\_ -> putMVar mvar ())+>     return mvar++      Note that we use 'forkFinally' to make sure that the+      'MVar' is written to even if the thread dies or+      is killed for some reason.++      A better method is to keep a global list of all child+      threads which we should wait for at the end of the program:++>    children :: MVar [MVar ()]+>    children = unsafePerformIO (newMVar [])+>+>    waitForChildren :: IO ()+>    waitForChildren = do+>      cs <- takeMVar children+>      case cs of+>        []   -> return ()+>        m:ms -> do+>           putMVar children ms+>           takeMVar m+>           waitForChildren+>+>    forkChild :: IO () -> IO ThreadId+>    forkChild io = do+>        mvar <- newEmptyMVar+>        childs <- takeMVar children+>        putMVar children (mvar:childs)+>        forkFinally io (\_ -> putMVar mvar ())+>+>     main =+>       later waitForChildren $+>       ...++      The main thread principle also applies to calls to Haskell from+      outside, using @foreign export@.  When the @foreign export@ed+      function is invoked, it starts a new main thread, and it returns+      when this main thread terminates.  If the call causes new+      threads to be forked, they may remain in the system after the+      @foreign export@ed function has returned.+-}++{- $preemption++      GHC implements pre-emptive multitasking: the execution of+      threads are interleaved in a random fashion.  More specifically,+      a thread may be pre-empted whenever it allocates some memory,+      which unfortunately means that tight loops which do no+      allocation tend to lock out other threads (this only seems to+      happen with pathological benchmark-style code, however).++      The rescheduling timer runs on a 20ms granularity by+      default, but this may be altered using the+      @-i\<n\>@ RTS option.  After a rescheduling+      \"tick\" the running thread is pre-empted as soon as+      possible.++      One final note: the+      @aaaa@ @bbbb@ example may not+      work too well on GHC (see Scheduling, above), due+      to the locking on a 'System.IO.Handle'.  Only one thread+      may hold the lock on a 'System.IO.Handle' at any one+      time, so if a reschedule happens while a thread is holding the+      lock, the other thread won't be able to run.  The upshot is that+      the switch from @aaaa@ to+      @bbbbb@ happens infrequently.  It can be+      improved by lowering the reschedule tick period.  We also have a+      patch that causes a reschedule whenever a thread waiting on a+      lock is woken up, but haven't found it to be useful for anything+      other than this example :-)+-}++{- $deadlock++GHC attempts to detect when threads are deadlocked using the garbage+collector.  A thread that is not reachable (cannot be found by+following pointers from live objects) must be deadlocked, and in this+case the thread is sent an exception.  The exception is either+'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM',+'NonTermination', or 'Deadlock', depending on the way in which the+thread is deadlocked.++Note that this feature is intended for debugging, and should not be+relied on for the correct operation of your program.  There is no+guarantee that the garbage collector will be accurate enough to detect+your deadlock, and no guarantee that the garbage collector will run in+a timely enough manner.  Basically, the same caveats as for finalizers+apply to deadlock detection.++There is a subtle interaction between deadlock detection and+finalizers (as created by 'GHC.Foreign.Concurrent.newForeignPtr' or the+functions in "System.Mem.Weak"): if a thread is blocked waiting for a+finalizer to run, then the thread will be considered deadlocked and+sent an exception.  So preferably don't do this, but if you have no+alternative then it is possible to prevent the thread from being+considered deadlocked by making a 'StablePtr' pointing to it.  Don't+forget to release the 'StablePtr' later with 'freeStablePtr'.+-}
+ src/Control/Concurrent/Chan.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.Chan+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (concurrency)+--+-- Unbounded channels.+--+-- The channels are implemented with 'Control.Concurrent.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+  (+          -- * The 'Chan' type+        Chan,                   -- abstract++          -- * Operations+        newChan,+        writeChan,+        readChan,+        dupChan,++          -- * Stream interface+        getChanContents,+        writeList2Chan,+   ) where++import Prelude+import System.IO.Unsafe         ( unsafeInterleaveIO )+import GHC.Internal.Control.Concurrent.MVar+import GHC.Internal.Control.Exception (mask_)++#define _UPK_(x) {-# UNPACK #-} !(x)++-- A channel is represented by two @MVar@s keeping track of the two ends+-- of the channel contents, i.e., the read- and write ends. Empty @MVar@s+-- are used to handle consumers trying to read from an empty channel.++-- |'Chan' is an abstract type representing an unbounded FIFO channel.+data Chan a+ = Chan _UPK_(MVar (Stream a))+        _UPK_(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar+   deriving Eq -- ^ @since 4.4.0.0++type Stream a = MVar (ChItem a)++data ChItem a = ChItem a _UPK_(Stream a)+  -- benchmarks show that unboxing the MVar here is worthwhile, because+  -- although it leads to higher allocation, the channel data takes up+  -- less space and is therefore quicker to GC.++-- See the Concurrent Haskell paper for a diagram explaining+-- how the different channel operations proceed.++-- @newChan@ sets up the read and write end of a channel by initialising+-- these two @MVar@s with an empty @MVar@.++-- |Build and return a new instance of 'Chan'.+newChan :: IO (Chan a)+newChan = do+   hole  <- newEmptyMVar+   readVar  <- newMVar hole+   writeVar <- newMVar hole+   return (Chan readVar writeVar)++-- To put an element on a channel, a new hole at the write end is created.+-- What was previously the empty @MVar@ at the back of the channel is then+-- filled in with a new stream element holding the entered value and the+-- new hole.++-- |Write a value to a 'Chan'.+writeChan :: Chan a -> a -> IO ()+writeChan (Chan _ writeVar) val = do+  new_hole <- newEmptyMVar+  mask_ $ do+    old_hole <- takeMVar writeVar+    putMVar old_hole (ChItem val new_hole)+    putMVar writeVar new_hole++-- The reason we don't simply do this:+--+--    modifyMVar_ writeVar $ \old_hole -> do+--      putMVar old_hole (ChItem val new_hole)+--      return new_hole+--+-- is because if an asynchronous exception is received after the 'putMVar'+-- completes and before modifyMVar_ installs the new value, it will set the+-- Chan's write end to a filled hole.++-- |Read the next value from the 'Chan'. Blocks when the channel is empty. Since+-- the read end of a channel is an 'MVar', this operation inherits fairness+-- guarantees of 'MVar's (e.g. threads blocked in this operation are woken up in+-- FIFO order).+--+-- Throws 'Control.Exception.BlockedIndefinitelyOnMVar' when the channel is+-- empty and no other thread holds a reference to the channel.+readChan :: Chan a -> IO a+readChan (Chan readVar _) =+  modifyMVar readVar $ \read_end -> do+    (ChItem val new_read_end) <- readMVar read_end+        -- Use readMVar here, not takeMVar,+        -- else dupChan doesn't work+    return (new_read_end, val)++-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to+-- either channel from then on will be available from both. Hence this creates+-- a kind of broadcast channel, where data written by anyone is seen by+-- everyone else.+--+-- (Note that a duplicated channel is not equal to its original.+-- So: @fmap (c /=) $ dupChan c@ returns @True@ for all @c@.)+dupChan :: Chan a -> IO (Chan a)+dupChan (Chan _ writeVar) = do+   hole       <- readMVar writeVar+   newReadVar <- newMVar hole+   return (Chan newReadVar writeVar)++-- Operators for interfacing with functional streams.++-- |Return a lazy list representing the contents of the supplied+-- 'Chan', much like 'GHC.Internal.System.IO.hGetContents'.+getChanContents :: Chan a -> IO [a]+getChanContents ch+  = unsafeInterleaveIO (do+        x  <- readChan ch+        xs <- getChanContents ch+        return (x:xs)+    )++-- |Write an entire list of items to a 'Chan'.+writeList2Chan :: Chan a -> [a] -> IO ()+writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
+ src/Control/Concurrent/MVar.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Concurrent.MVar+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (concurrency)+--+-- An @'MVar' t@ is a mutable location that is either empty or contains a+-- value of type @t@.  It has two fundamental operations: 'putMVar'+-- which fills an 'MVar' if it is empty and blocks otherwise, and+-- 'takeMVar' which empties an 'MVar' if it is full and blocks+-- otherwise.  They can be used in multiple different ways:+--+--   1. As synchronized mutable variables,+--+--   2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and+--+--   3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as+--      wait and signal.+--+-- They were introduced in the paper+-- ["Concurrent Haskell"](https://www.microsoft.com/en-us/research/wp-content/uploads/1996/01/concurrent-haskell.pdf)+-- by Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne, though+-- some details of their implementation have since then changed (in+-- particular, a put on a full 'MVar' used to error, but now merely+-- blocks.)+--+-- === Applicability+--+-- 'MVar's offer more flexibility than 'Data.IORef.IORef's, but less flexibility+-- than 'GHC.Conc.STM'.  They are appropriate for building synchronization+-- primitives and performing simple inter-thread communication; however+-- they are very simple and susceptible to race conditions, deadlocks or+-- uncaught exceptions.  Do not use them if you need to perform larger+-- atomic operations such as reading from multiple variables: use 'GHC.Conc.STM'+-- instead.+--+-- In particular, the "bigger" functions in this module ('swapMVar',+-- 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply+-- the composition of a 'takeMVar' followed by a 'putMVar' with+-- exception safety.+-- These have atomicity guarantees only if all other threads+-- perform a 'takeMVar' before a 'putMVar' as well;  otherwise, they may+-- block.+--+-- === Fairness+--+-- No thread can be blocked indefinitely on an 'MVar' unless another+-- thread holds that 'MVar' indefinitely.  One usual implementation of+-- this fairness guarantee is that threads blocked on an 'MVar' are+-- served in a first-in-first-out fashion (this is what GHC does),+-- but this is not guaranteed in the semantics.+--+-- === Gotchas+--+-- Like many other Haskell data structures, 'MVar's are lazy.  This+-- means that if you place an expensive unevaluated thunk inside an+-- 'MVar', it will be evaluated by the thread that consumes it, not the+-- thread that produced it.  Be sure to 'evaluate' values to be placed+-- in an 'MVar' to the appropriate normal form, or utilize a strict+-- @MVar@ provided by the [strict-concurrency](https://hackage.haskell.org/package/strict-concurrency) package.+--+-- === Ordering+--+-- 'MVar' operations are always observed to take place in the order+-- they are written in the program, regardless of the memory model of+-- the underlying machine.  This is in contrast to 'Data.IORef.IORef' operations+-- which may appear out-of-order to another thread in some cases.+--+-- === Example+--+-- Consider the following concurrent data structure, a skip channel.+-- This is a channel for an intermittent source of high bandwidth+-- information (for example, mouse movement events.)  Writing to the+-- channel never blocks, and reading from the channel only returns the+-- most recent value, or blocks if there are no new values.  Multiple+-- readers are supported with a @dupSkipChan@ operation.+--+-- A skip channel is a pair of 'MVar's. The first 'MVar' contains the+-- current value, and a list of semaphores that need to be notified+-- when it changes. The second 'MVar' is a semaphore for this particular+-- reader: it is full if there is a value in the channel that this+-- reader has not read yet, and empty otherwise.+--+-- @+-- data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ())+--+-- newSkipChan :: IO (SkipChan a)+-- newSkipChan = do+--     sem <- newEmptyMVar+--     main <- newMVar (undefined, [sem])+--     return (SkipChan main sem)+--+-- putSkipChan :: SkipChan a -> a -> IO ()+-- putSkipChan (SkipChan main _) v = do+--     (_, sems) <- takeMVar main+--     putMVar main (v, [])+--     mapM_ (\\sem -> putMVar sem ()) sems+--+-- getSkipChan :: SkipChan a -> IO a+-- getSkipChan (SkipChan main sem) = do+--     takeMVar sem+--     (v, sems) <- takeMVar main+--     putMVar main (v, sem : sems)+--     return v+--+-- dupSkipChan :: SkipChan a -> IO (SkipChan a)+-- dupSkipChan (SkipChan main _) = do+--     sem <- newEmptyMVar+--     (v, sems) <- takeMVar main+--     putMVar main (v, sem : sems)+--     return (SkipChan main sem)+-- @+--+-- This example was adapted from the original Concurrent Haskell paper.+-- For more examples of 'MVar's being used to build higher-level+-- synchronization primitives, see 'Control.Concurrent.Chan' and+-- 'Control.Concurrent.QSem'.+--++module Control.Concurrent.MVar+    (-- *  @MVar@s+     MVar,+     newEmptyMVar,+     newMVar,+     takeMVar,+     putMVar,+     readMVar,+     swapMVar,+     tryTakeMVar,+     tryPutMVar,+     isEmptyMVar,+     withMVar,+     withMVarMasked,+     modifyMVar_,+     modifyMVar,+     modifyMVarMasked_,+     modifyMVarMasked,+     tryReadMVar,+     mkWeakMVar,+     addMVarFinalizer+     ) where++import GHC.Internal.Control.Concurrent.MVar
+ src/Control/Concurrent/QSem.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE BangPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.QSem+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (concurrency)+--+-- Simple quantity semaphores.+--+-----------------------------------------------------------------------------++module Control.Concurrent.QSem+        ( -- * Simple Quantity Semaphores+          QSem,         -- abstract+          newQSem,      -- :: Int  -> IO QSem+          waitQSem,     -- :: QSem -> IO ()+          signalQSem    -- :: QSem -> IO ()+        ) where++import Prelude+import GHC.Internal.Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, tryTakeMVar+                          , putMVar, newMVar, tryPutMVar)+import GHC.Internal.Control.Exception+import GHC.Internal.Data.Maybe++-- | 'QSem' is a quantity semaphore in which the resource is acquired+-- and released in units of one. It provides guaranteed FIFO ordering+-- for satisfying blocked `waitQSem` calls.+--+-- The pattern+--+-- > bracket_ waitQSem signalQSem (...)+--+-- is safe; it never loses a unit of the resource.+--+newtype QSem = QSem (MVar (Int, [MVar ()], [MVar ()]))++-- The semaphore state (i, xs, ys):+--+--   i is the current resource value+--+--   (xs,ys) is the queue of blocked threads, where the queue is+--           given by xs ++ reverse ys.  We can enqueue new blocked threads+--           by consing onto ys, and dequeue by removing from the head of xs.+--+-- A blocked thread is represented by an empty (MVar ()).  To unblock+-- the thread, we put () into the MVar.+--+-- A thread can dequeue itself by also putting () into the MVar, which+-- it must do if it receives an exception while blocked in waitQSem.+-- This means that when unblocking a thread in signalQSem we must+-- first check whether the MVar is already full; the MVar lock on the+-- semaphore itself resolves race conditions between signalQSem and a+-- thread attempting to dequeue itself.++-- |Build a new 'QSem' with a supplied initial quantity.+--  The initial quantity must be at least 0.+newQSem :: Int -> IO QSem+newQSem initial+  | initial < 0 = fail "newQSem: Initial quantity must be non-negative"+  | otherwise   = do+      sem <- newMVar (initial, [], [])+      return (QSem sem)++-- |Wait for a unit to become available.+waitQSem :: QSem -> IO ()+waitQSem (QSem m) =+  mask_ $ do+    (i,b1,b2) <- takeMVar m+    if i == 0+       then do+         b <- newEmptyMVar+         putMVar m (i, b1, b:b2)+         wait b+       else do+         let !z = i-1+         putMVar m (z, b1, b2)+         return ()+  where+    wait b = takeMVar b `onException`+                (uninterruptibleMask_ $ do -- Note [signal uninterruptible]+                   (i,b1,b2) <- takeMVar m+                   r <- tryTakeMVar b+                   r' <- if isJust r+                            then signal (i,b1,b2)+                            else do putMVar b (); return (i,b1,b2)+                   putMVar m r')++-- |Signal that a unit of the 'QSem' is available.+signalQSem :: QSem -> IO ()+signalQSem (QSem m) =+  uninterruptibleMask_ $ do -- Note [signal uninterruptible]+    r <- takeMVar m+    r' <- signal r+    putMVar m r'++-- Note [signal uninterruptible]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--   If we have+--+--      bracket waitQSem signalQSem (...)+--+--   and an exception arrives at the signalQSem, then we must not lose+--   the resource.  The signalQSem is masked by bracket, but taking+--   the MVar might block, and so it would be interruptible.  Hence we+--   need an uninterruptibleMask here.+--+--   This isn't ideal: during high contention, some threads won't be+--   interruptible.  The QSemSTM implementation has better behaviour+--   here, but it performs much worse than this one in some+--   benchmarks.++signal :: (Int,[MVar ()],[MVar ()]) -> IO (Int,[MVar ()],[MVar ()])+signal (i,a1,a2) =+ if i == 0+   then loop a1 a2+   else let !z = i+1 in return (z, a1, a2)+ where+   loop [] [] = return (1, [], [])+   loop [] b2 = loop (reverse b2) []+   loop (b:bs) b2 = do+     r <- tryPutMVar b ()+     if r then return (0, bs, b2)+          else loop bs b2
+ src/Control/Concurrent/QSemN.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.QSemN+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (concurrency)+--+-- Quantity semaphores in which each thread may wait for an arbitrary+-- \"amount\".+--+-----------------------------------------------------------------------------++module Control.Concurrent.QSemN+        (  -- * General Quantity Semaphores+          QSemN,        -- abstract+          newQSemN,     -- :: Int   -> IO QSemN+          waitQSemN,    -- :: QSemN -> Int -> IO ()+          signalQSemN   -- :: QSemN -> Int -> IO ()+      ) where++import Prelude+import GHC.Internal.Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar+                          , tryPutMVar, isEmptyMVar)+import GHC.Internal.Control.Exception+import GHC.Internal.Control.Monad (when)+import GHC.Internal.Data.IORef (IORef, newIORef, atomicModifyIORef)+import System.IO.Unsafe (unsafePerformIO)++-- | 'QSemN' is a quantity semaphore in which the resource is acquired+-- and released in arbitrary amounts. It provides guaranteed FIFO ordering+-- for satisfying blocked `waitQSemN` calls.+--+-- The pattern+--+-- > bracket_ (waitQSemN n) (signalQSemN n) (...)+--+-- is safe; it never loses any of the resource.+--+data QSemN = QSemN !(IORef (Int, [(Int, MVar ())], [(Int, MVar ())]))++-- The semaphore state (i, xs, ys):+--+--   i is the current resource value+--+--   (xs,ys) is the queue of blocked threads, where the queue is+--           given by xs ++ reverse ys.  We can enqueue new blocked threads+--           by consing onto ys, and dequeue by removing from the head of xs.+--+-- A blocked thread is represented by an empty (MVar ()).  To unblock+-- the thread, we put () into the MVar.+--+-- A thread can dequeue itself by also putting () into the MVar, which+-- it must do if it receives an exception while blocked in waitQSemN.+-- This means that when unblocking a thread in signalQSemN we must+-- first check whether the MVar is already full.++-- |Build a new 'QSemN' with a supplied initial quantity.+--  The initial quantity must be at least 0.+newQSemN :: Int -> IO QSemN+newQSemN initial+  | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"+  | otherwise   = do+      sem <- newIORef (initial, [], [])+      return (QSemN sem)++-- An unboxed version of Maybe (MVar a)+data MaybeMV a = JustMV !(MVar a) | NothingMV++-- |Wait for the specified quantity to become available.+waitQSemN :: QSemN -> Int -> IO ()+-- We need to mask here. Once we've enqueued our MVar, we need+-- to be sure to wait for it. Otherwise, we could lose our+-- allocated resource.+waitQSemN qs@(QSemN m) sz = mask_ $ do+    -- unsafePerformIO and not unsafeDupablePerformIO. We must+    -- be sure to wait on the same MVar that gets enqueued.+  mmvar <- atomicModifyIORef m $ \ (i,b1,b2) -> unsafePerformIO $ do+    let z = i-sz+    if z < 0+      then do+        b <- newEmptyMVar+        return ((i, b1, (sz,b):b2), JustMV b)+      else return ((z, b1, b2), NothingMV)++  -- Note: this case match actually allocates the MVar if necessary.+  case mmvar of+    NothingMV -> return ()+    JustMV b -> wait b+  where+    wait :: MVar () -> IO ()+    wait b =+      takeMVar b `onException` do+        already_filled <- not <$> tryPutMVar b ()+        when already_filled $ signalQSemN qs sz++-- |Signal that a given quantity is now available from the 'QSemN'.+signalQSemN :: QSemN -> Int -> IO ()+-- We don't need to mask here because we should *already* be masked+-- here (e.g., by bracket). Indeed, if we're not already masked,+-- it's too late to do so.+--+-- What if the unsafePerformIO thunk is forced in another thread,+-- and receives an asynchronous exception? That shouldn't be a+-- problem: when we force it ourselves, presumably masked, we+-- will resume its execution.+signalQSemN (QSemN m) sz0 = do+    -- unsafePerformIO and not unsafeDupablePerformIO. We must not+    -- wake up more threads than we're supposed to.+  unit <- atomicModifyIORef m $ \(i,a1,a2) ->+            unsafePerformIO (loop (sz0 + i) a1 a2)++  -- Forcing this will actually wake the necessary threads.+  evaluate unit+ where+   loop 0  bs b2 = return ((0,  bs, b2), ())+   loop sz [] [] = return ((sz, [], []), ())+   loop sz [] b2 = loop sz (reverse b2) []+   loop sz ((j,b):bs) b2+     | j > sz = do+       r <- isEmptyMVar b+       if r then return ((sz, (j,b):bs, b2), ())+            else loop sz bs b2+     | otherwise = do+       r <- tryPutMVar b ()+       if r then loop (sz-j) bs b2+            else loop sz bs b2
+ src/Control/Exception.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE Trustworthy #-}++-- |+--+-- Module      :  Control.Exception+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (extended exceptions)+--+-- This module provides support for raising and catching both built-in+-- and user-defined exceptions.+--+-- In addition to exceptions thrown by 'IO' operations, exceptions may+-- be thrown by pure code (imprecise exceptions) or by external events+-- (asynchronous exceptions), but may only be caught in the 'IO' monad.+-- For more details, see:+--+--  * /A semantics for imprecise exceptions/, by Simon Peyton Jones,+--    Alastair Reid, Tony Hoare, Simon Marlow, Fergus Henderson,+--    in /PLDI'99/.+--+--  * /Asynchronous exceptions in Haskell/, by Simon Marlow, Simon Peyton+--    Jones, Andy Moran and John Reppy, in /PLDI'01/.+--+--  * /An Extensible Dynamically-Typed Hierarchy of Exceptions/,+--    by Simon Marlow, in /Haskell '06/.+--++module Control.Exception+    (-- * The 'SomeException' type+     SomeException(..),+     -- ** The 'Exception' class+     Exception(..),+     addExceptionContext,+     someExceptionContext,+     annotateIO,+     NoBacktrace(..),+     ExceptionWithContext(..),+     WhileHandling(..),++     -- * Concrete exception types+     IOException,+     ArithException(..),+     ArrayException(..),+     AssertionFailed(..),+     NoMethodError(..),+     PatternMatchFail(..),+     RecConError(..),+     RecSelError(..),+     RecUpdError(..),+     ErrorCall(..),+     TypeError(..),+     -- ** Asynchronous exceptions+     SomeAsyncException(..),+     AsyncException(..),+     asyncExceptionToException,+     asyncExceptionFromException,+     NonTermination(..),+     NestedAtomically(..),+     BlockedIndefinitelyOnMVar(..),+     BlockedIndefinitelyOnSTM(..),+     AllocationLimitExceeded(..),+     CompactionFailed(..),+     Deadlock(..),+     -- *  Throwing exceptions+     throw,+     throwIO,+     rethrowIO,+     ioError,+     throwTo,+     -- *  Catching Exceptions+     -- $catching+     -- **  Catching all exceptions+     -- $catchall+     -- **  The @catch@ functions+     catch,+     catchNoPropagate,+     catches,+     Handler(..),+     catchJust,+     -- **  The @handle@ functions+     handle,+     handleJust,+     -- **  The @try@ functions+     try,+     tryWithContext,+     tryJust,+     -- **  The @evaluate@ function+     evaluate,+     -- **  The @mapException@ function+     mapException,+     -- *  Asynchronous Exceptions+     -- $async+     -- **  Asynchronous exception control+     -- | The following functions allow a thread to control delivery of+     -- asynchronous exceptions during a critical region.+     mask,+     mask_,+     uninterruptibleMask,+     uninterruptibleMask_,+     MaskingState(..),+     getMaskingState,+     interruptible,+     allowInterrupt,+     -- ***  Applying @mask@ to an exception handler+     -- $block_handler+     -- ***  Interruptible operations+     -- $interruptible+     -- *  Assertions+     assert,+     -- *  Utilities+     bracket,+     bracket_,+     bracketOnError,+     finally,+     onException,+     -- ** Printing+     displayExceptionWithInfo++     ) where++import GHC.Internal.Control.Exception+import GHC.Internal.Exception.Type++{- $catching++There are several functions for catching and examining+exceptions; all of them may only be used from within the+'IO' monad.++Here's a rule of thumb for deciding which catch-style function to+use:++ * If you want to do some cleanup in the event that an exception+   is raised, use 'finally', 'bracket' or 'onException'.++ * To recover after an exception and do something else, the best+   choice is to use one of the 'try' family.++ * ... unless you are recovering from an asynchronous exception, in which+   case use 'catch' or 'catchJust'.++The difference between using 'try' and 'catch' for recovery is that in+'catch' the handler is inside an implicit 'mask' (see \"Asynchronous+Exceptions\") which is important when catching asynchronous+exceptions, but when catching other kinds of exception it is+unnecessary.  Furthermore it is possible to accidentally stay inside+the implicit 'mask' by tail-calling rather than returning from the+handler, which is why we recommend using 'try' rather than 'catch' for+ordinary exception recovery.++A typical use of 'tryJust' for recovery looks like this:++>  do r <- tryJust (guard . isDoesNotExistError) $ getEnv "HOME"+>     case r of+>       Left  e    -> ...+>       Right home -> ...++-}++{- $async++ #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to+external influences, and can be raised at any point during execution.+'StackOverflow' and 'HeapOverflow' are two examples of+system-generated asynchronous exceptions.++The primary source of asynchronous exceptions, however, is+'throwTo':++>  throwTo :: ThreadId -> Exception -> IO ()++'throwTo' (also 'Control.Concurrent.killThread') allows one+running thread to raise an arbitrary exception in another thread.  The+exception is therefore asynchronous with respect to the target thread,+which could be doing anything at the time it receives the exception.+Great care should be taken with asynchronous exceptions; it is all too+easy to introduce race conditions by the over zealous use of+'throwTo'.+-}++{- $block_handler+There\'s an implied 'mask' around every exception handler in a call+to one of the 'catch' family of functions.  This is because that is+what you want most of the time - it eliminates a common race condition+in starting an exception handler, because there may be no exception+handler on the stack to handle another exception if one arrives+immediately.  If asynchronous exceptions are masked on entering the+handler, though, we have time to install a new exception handler+before being interrupted.  If this weren\'t the default, one would have+to write something like++>      mask $ \restore ->+>           catch (restore (...))+>                 (\e -> handler)++If you need to unmask asynchronous exceptions again in the exception+handler, @restore@ can be used there too.++Note that 'try' and friends /do not/ have a similar default, because+there is no exception handler in this case.  Don't use 'try' for+recovering from an asynchronous exception.+-}++{- $interruptible++ #interruptible#+Some operations are /interruptible/, which means that they can receive+asynchronous exceptions even in the scope of a 'mask'.  Any function+which may itself block is defined as interruptible; this includes+'Control.Concurrent.MVar.takeMVar'+(but not 'Control.Concurrent.MVar.tryTakeMVar'),+and most operations which perform+some I\/O with the outside world.  The reason for having+interruptible operations is so that we can write things like++>      mask $ \restore -> do+>         a <- takeMVar m+>         catch (restore (...))+>               (\e -> ...)++if the 'Control.Concurrent.MVar.takeMVar' was not interruptible,+then this particular+combination could lead to deadlock, because the thread itself would be+blocked in a state where it can\'t receive any asynchronous exceptions.+With 'Control.Concurrent.MVar.takeMVar' interruptible, however, we can be+safe in the knowledge that the thread can receive exceptions right up+until the point when the 'Control.Concurrent.MVar.takeMVar' succeeds.+Similar arguments apply for other interruptible operations like+'System.IO.openFile'.++It is useful to think of 'mask' not as a way to completely prevent+asynchronous exceptions, but as a way to switch from asynchronous mode+to polling mode.  The main difficulty with asynchronous+exceptions is that they normally can occur anywhere, but within a+'mask' an asynchronous exception is only raised by operations that are+interruptible (or call other interruptible operations).  In many cases+these operations may themselves raise exceptions, such as I\/O errors,+so the caller will usually be prepared to handle exceptions arising from the+operation anyway.  To perform an explicit poll for asynchronous exceptions+inside 'mask', use 'allowInterrupt'.++Sometimes it is too onerous to handle exceptions in the middle of a+critical piece of stateful code.  There are three ways to handle this+kind of situation:++ * Use STM.  Since a transaction is always either completely executed+   or not at all, transactions are a good way to maintain invariants+   over state in the presence of asynchronous (and indeed synchronous)+   exceptions.++ * Use 'mask', and avoid interruptible operations.  In order to do+   this, we have to know which operations are interruptible.  It is+   impossible to know for any given library function whether it might+   invoke an interruptible operation internally; so instead we give a+   list of guaranteed-not-to-be-interruptible operations below.++ * Use 'uninterruptibleMask'.  This is generally not recommended,+   unless you can guarantee that any interruptible operations invoked+   during the scope of 'uninterruptibleMask' can only ever block for+   a short time.  Otherwise, 'uninterruptibleMask' is a good way to+   make your program deadlock and be unresponsive to user interrupts.++The following operations are guaranteed not to be interruptible:++ * operations on 'Data.IORef.IORef' from "Data.IORef"++ * STM transactions that do not use 'Conc.retry'++ * everything from the @Foreign@ modules++ * everything from "Control.Exception" except for 'throwTo'++ * 'Control.Concurrent.MVar.tryTakeMVar', 'Control.Concurrent.MVar.tryPutMVar',+   'Control.Concurrent.MVar.isEmptyMVar'++ * 'Control.Concurrent.MVar.takeMVar' if the 'Control.Concurrent.MVar.MVar' is+   definitely full, and conversely 'Control.Concurrent.MVar.putMVar' if the+   'Control.Concurrent.MVar.MVar' is definitely empty++ * 'Control.Concurrent.MVar.newEmptyMVar', 'Control.Concurrent.MVar.newMVar'++ * 'Control.Concurrent.forkIO', 'Control.Concurrent.myThreadId'++-}++{- $catchall++It is possible to catch all exceptions, by using the type 'SomeException':++> catch f (\e -> ... (e :: SomeException) ...)++HOWEVER, this is normally not what you want to do!++For example, suppose you want to read a file, but if it doesn't exist+then continue as if it contained \"\".  You might be tempted to just+catch all exceptions and return \"\" in the handler. However, this has+all sorts of undesirable consequences.  For example, if the user+presses control-C at just the right moment then the 'UserInterrupt'+exception will be caught, and the program will continue running under+the belief that the file contains \"\".  Similarly, if another thread+tries to kill the thread reading the file then the 'ThreadKilled'+exception will be ignored.++Instead, you should only catch exactly the exceptions that you really+want. In this case, this would likely be more specific than even+\"any IO exception\"; a permissions error would likely also want to be+handled differently. Instead, you would probably want something like:++> e <- tryJust (guard . isDoesNotExistError) (readFile f)+> let str = either (const "") id e++There are occasions when you really do need to catch any sort of+exception. However, in most cases this is just so you can do some+cleaning up; you aren't actually interested in the exception itself.+For example, if you open a file then you want to close it again,+whether processing the file executes normally or throws an exception.+However, in these cases you can use functions like 'bracket', 'finally'+and 'onException', which never actually pass you the exception, but+just call the cleanup functions at the appropriate points.++But sometimes you really do need to catch any exception, and actually+see what the exception is. One example is at the very top-level of a+program, you may wish to catch any exception, print it to a logfile or+the screen, and then exit gracefully. For these cases, you can use+'catch' (or one of the other exception-catching functions) with the+'SomeException' type.+-}+
+ src/Control/Exception/Annotation.hs view
@@ -0,0 +1,18 @@+-- |+-- Module      :  Control.Exception.Annotation+-- Copyright   :  (c) The University of Glasgow, 1998-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Exception annotations.+--+module Control.Exception.Annotation+    ( SomeExceptionAnnotation(..)+    , ExceptionAnnotation(..)+    ) where++import GHC.Internal.Exception.Context+
+ src/Control/Exception/Backtrace.hs view
@@ -0,0 +1,59 @@+-- |+-- Module      :  Control.Exception.Backtrace+-- Copyright   :  (c) The University of Glasgow 1994-2023+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides the 'Backtrace'\ s type, which provides a+-- common representation for backtrace information which can be, e.g., attached+-- to exceptions (via the 'Control.Exception.Context.ExceptionContext' facility).+-- These backtraces preserve useful context about the execution state of the program+-- using a variety of means; we call these means *backtrace mechanisms*.+--+-- We currently support four backtrace mechanisms:+--+--  - 'CostCentreBacktrace' captures the current cost-centre stack+--    using 'GHC.Stack.CCS.getCurrentCCS'.+--  - 'HasCallStackBacktrace' captures the 'HasCallStack' 'CallStack'.+--  - 'ExecutionBacktrace' captures the execution stack, unwound and resolved+--    to symbols via DWARF debug information.+--  - 'IPEBacktrace' captures the execution stack, resolved to names via info-table+--    provenance information.+--+-- Each of these are useful in different situations. While 'CostCentreBacktrace's are+-- readily mapped back to the source program, they require that the program be instrumented+-- with cost-centres, incurring runtime cost. Similarly, 'HasCallStackBacktrace's require that+-- the program be manually annotated with 'HasCallStack' constraints.+--+-- By contrast, 'IPEBacktrace's incur no runtime instrumentation but require that (at least+-- some subset of) the program be built with GHC\'s @-finfo-table-map@ flag. Moreover, because+-- info-table provenance information is derived after optimisation, it may be harder to relate+-- back to the structure of the source program.+--+-- 'ExecutionBacktrace's are similar to 'IPEBacktrace's but use DWARF stack unwinding+-- and symbol resolution; this allows for useful backtraces even in the presence+-- of foreign calls, both into and out of Haskell. However, for robust stack unwinding+-- the entirety of the program (and its dependencies, both Haskell and native) must+-- be compiled with debugging information (e.g. using GHC\'s @-g@ flag).+++-- Note [Backtrace mechanisms]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See module docstring above.+++module Control.Exception.Backtrace+    ( -- * Backtrace mechanisms+      BacktraceMechanism(..)+    , getBacktraceMechanismState+    , setBacktraceMechanismState+      -- * Collecting backtraces+    , Backtraces+    , displayBacktraces+    , collectBacktraces+    ) where++import GHC.Internal.Exception.Backtrace
+ src/Control/Exception/Base.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Exception.Base+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (extended exceptions)+--+-- Extensible exceptions, except for multiple handlers.+--++module Control.Exception.Base+    (-- *  The Exception type+     SomeException(..),+     Exception(..),+     IOException,+     ArithException(..),+     ArrayException(..),+     AssertionFailed(..),+     SomeAsyncException(..),+     AsyncException(..),+     asyncExceptionToException,+     asyncExceptionFromException,+     NonTermination(..),+     NestedAtomically(..),+     BlockedIndefinitelyOnMVar(..),+     FixIOException(..),+     BlockedIndefinitelyOnSTM(..),+     AllocationLimitExceeded(..),+     CompactionFailed(..),+     Deadlock(..),+     NoMethodError(..),+     PatternMatchFail(..),+     RecConError(..),+     RecSelError(..),+     RecUpdError(..),+     ErrorCall(..),+     TypeError(..),+     NoMatchingContinuationPrompt(..),+     -- *  Throwing exceptions+     throwIO,+     throw,+     ioError,+     throwTo,+     -- *  Catching Exceptions+     -- **  The @catch@ functions+     catch,+     catchJust,+     -- **  The @handle@ functions+     handle,+     handleJust,+     -- **  The @try@ functions+     try,+     tryJust,+     onException,+     -- **  The @evaluate@ function+     evaluate,+     -- **  The @mapException@ function+     mapException,+     -- *  Asynchronous Exceptions+     -- **  Asynchronous exception control+     mask,+     mask_,+     uninterruptibleMask,+     uninterruptibleMask_,+     MaskingState(..),+     getMaskingState,+     -- *  Assertions+     assert,+     -- *  Utilities+     bracket,+     bracket_,+     bracketOnError,+     finally,+     -- *  Calls for GHC runtime+     recSelError,+     recConError,+     impossibleError,+     impossibleConstraintError,+     nonExhaustiveGuardsError,+     patError,+     noMethodBindingError,+     typeError,+     nonTermination,+     nestedAtomically,+     noMatchingContinuationPrompt+     ) where++import GHC.Internal.Control.Exception.Base
+ src/Control/Exception/Context.hs view
@@ -0,0 +1,22 @@+-- |+-- Module      :  Control.Exception.Context+-- Copyright   :  (c) The University of Glasgow, 1998-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Exception context and annotations.+--+module Control.Exception.Context+    ( ExceptionContext(..)+    , emptyExceptionContext+    , addExceptionAnnotation+      -- * Destructuring+    , getExceptionAnnotations+    , getAllExceptionAnnotations+    , displayExceptionContext+    ) where++import GHC.Internal.Exception.Context
+ src/Control/Monad.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Monad+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'Functor', 'Monad' and 'MonadPlus' classes,+-- with some useful operations on monads.++module Control.Monad+    (-- *  Functor and monad classes+     Functor(..),+     Monad((>>=), (>>), return),+     MonadFail(fail),+     MonadPlus(mzero, mplus),+     -- *  Functions+     -- **  Naming conventions+     -- $naming+     -- **  Basic @Monad@ functions+     mapM,+     mapM_,+     forM,+     forM_,+     sequence,+     sequence_,+     (=<<),+     (>=>),+     (<=<),+     forever,+     void,+     -- **  Generalisations of list functions+     join,+     msum,+     mfilter,+     filterM,+     mapAndUnzipM,+     zipWithM,+     zipWithM_,+     foldM,+     foldM_,+     replicateM,+     replicateM_,+     -- **  Conditional execution of monadic expressions+     guard,+     when,+     unless,+     -- **  Monadic lifting operators+     liftM,+     liftM2,+     liftM3,+     liftM4,+     liftM5,+     ap,+     -- **  Strict monadic functions+     (<$!>)+     ) where++import GHC.Internal.Control.Monad++{- $naming++The functions in this module use the following naming conventions:++* A postfix \'@M@\' always stands for a function in the Kleisli category:+  The monad type constructor @m@ is added to function results+  (modulo currying) and nowhere else.  So, for example,++> filter  ::              (a ->   Bool) -> [a] ->   [a]+> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]++* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@.+  Thus, for example:++> sequence  :: Monad m => [m a] -> m [a]+> sequence_ :: Monad m => [m a] -> m ()++* A prefix \'@m@\' generalizes an existing function to a monadic form.+  Thus, for example:++> filter  ::                (a -> Bool) -> [a] -> [a]+> mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a++-}
+ src/Control/Monad/Fail.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE Safe #-}++-- |+--+-- 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 <https://gitlab.haskell.org/haskell/prime/-/wikis/libraries/proposals/monad-fail>+-- for more details.+--+-- @since 4.9.0.0+--++module Control.Monad.Fail+    (MonadFail(fail)) where++import GHC.Internal.Control.Monad.Fail
+ src/Control/Monad/Fix.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Monad.Fix+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Monadic fixpoints, used for desugaring of @{-# LANGUAGE RecursiveDo #-}@.+--+-- Consider the generalized version of so-called @repmin@+-- (/replace with minimum/) problem:+-- accumulate elements of a container into a 'Monoid'+-- and modify each element using the final accumulator.+--+-- @+-- repmin+--   :: (Functor t, Foldable t, Monoid b)+--   => (a -> b) -> (a -> b -> c) -> t a -> t c+-- repmin f g as = fmap (\`g\` foldMap f as) as+-- @+--+-- The naive implementation as above makes two traversals. Can we do better+-- and achieve the goal in a single pass? It's seemingly impossible, because we would+-- have to know the future,+-- but lazy evaluation comes to the rescue:+--+-- @+-- import Data.Traversable (mapAccumR)+--+-- repmin+--   :: (Traversable t, Monoid b)+--   => (a -> b) -> (a -> b -> c) -> t a -> t c+-- repmin f g as =+--   let (b, cs) = mapAccumR (\\acc a -> (f a <> acc, g a b)) mempty as in cs+-- @+--+-- How can we check that @repmin@ indeed traverses only once?+-- Let's run it on an infinite input:+--+-- >>> import Data.Monoid (All(..))+-- >>> take 3 $ repmin All (const id) ([True, True, False] ++ undefined)+-- [All {getAll = False},All {getAll = False},All {getAll = False}]+--+-- So far so good, but can we generalise @g@ to return a monadic value @a -> b -> m c@?+-- The following does not work, complaining that @b@ is not in scope:+--+-- @+-- import Data.Traversable (mapAccumM)+--+-- repminM+--   :: (Traversable t, Monoid b, Monad m)+--   => (a -> b) -> (a -> b -> m c) -> t a -> m (t c)+-- repminM f g as = do+--   (b, cs) \<- mapAccumM (\\acc a -> (f a <> acc,) \<$\> g a b) mempty as+--   pure cs+-- @+--+-- To solve the riddle, let's rewrite @repmin@ via 'fix':+--+-- @+-- repmin+--   :: (Traversable t, Monoid b)+--   => (a -> b) -> (a -> b -> c) -> t a -> t c+-- repmin f g as = snd $ fix $+--   \\(b, cs) -> mapAccumR (\\acc a -> (f a <> acc, g a b)) mempty as+-- @+--+-- Now we can replace 'fix' with 'mfix' to obtain the solution:+--+-- @+-- repminM+--   :: (Traversable t, Monoid b, MonadFix m)+--   => (a -> b) -> (a -> b -> m c) -> t a -> m (t c)+-- repminM f g as = fmap snd $ mfix $+--   \\(~(b, cs)) -> mapAccumM (\\acc a -> (f a <> acc,) \<$\> g a b) mempty as+-- @+--+-- For example,+--+-- >>> import Data.Monoid (Sum(..))+-- >>> repminM Sum (\a b -> print a >> pure (a + getSum b)) [3, 5, 2]+-- 3+-- 5+-- 2+-- [13,15,12]+--+-- Incredibly, GHC is capable to do this transformation automatically,+-- when @{-# LANGUAGE RecursiveDo #-}@ is enabled. Namely, the following+-- implementation of @repminM@ works (note @mdo@ instead of @do@):+--+-- @+-- {-# LANGUAGE RecursiveDo #-}+--+-- repminM+--   :: (Traversable t, Monoid b, MonadFix m)+--   => (a -> b) -> (a -> b -> m c) -> t a -> m (t c)+-- repminM f g as = mdo+--   (b, cs) \<- mapAccumM (\\acc a -> (f a <> acc,) \<$\> g a b) mempty as+--   pure cs+-- @+--+-- Further reading:+--+-- * GHC User’s Guide, The recursive do-notation.+-- * Haskell Wiki, <https://wiki.haskell.org/MonadFix MonadFix>.+-- * Levent Erkök, <https://leventerkok.github.io/papers/erkok-thesis.pdf Value recursion in monadic computations>, Oregon Graduate Institute, 2002.+-- * Levent Erkök, John Launchbury, <https://leventerkok.github.io/papers/recdo.pdf A recursive do for Haskell>, Haskell '02, 29-37, 2002.+-- * Richard S. Bird, <https://doi.org/10.1007/BF00264249 Using circular programs to eliminate multiple traversals of data>, Acta Informatica 21, 239-250, 1984.+-- * Jasper Van der Jeugt, <https://jaspervdj.be/posts/2023-07-22-lazy-layout.html Lazy layout>, 2023.++module Control.Monad.Fix+    (MonadFix(mfix),+     fix+     ) where++import GHC.Internal.Control.Monad.Fix
+ src/Control/Monad/IO/Class.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- 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   :  stable+-- Portability :  portable+--+-- Class of monads based on @IO@.+-----------------------------------------------------------------------------++module Control.Monad.IO.Class+  ( MonadIO(..) )+  where++import GHC.Internal.Control.Monad.IO.Class
+ src/Control/Monad/Instances.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Trustworthy #-}++-- |+--+-- Module      :  Control.Monad.Instances+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- /This module is DEPRECATED and will be removed in the future!/+--+-- 'Functor' and 'Monad' instances for @(->) r@ and+-- 'Functor' instances for @(,) a@ and @'Either' a@.++module Control.Monad.Instances+    {-# DEPRECATED "This module now contains no instances and will be removed in the future" #-} -- deprecated in 7.8+    ( Functor(..),+      Monad(..)+    ) where++import GHC.Internal.Base (Functor(..), Monad(..))
+ src/Control/Monad/ST.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Monad.ST+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (requires universal quantification for runST)+--+-- This module provides support for /strict/ state threads, as+-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton+-- Jones /Lazy Functional State Threads/.+--+-- References (variables) that can be used within the @ST@ monad are+-- provided by "Data.STRef", and arrays are provided by+-- [Data.Array.ST](https://hackage.haskell.org/package/array/docs/Data-Array-ST.html).++module Control.Monad.ST+    (-- *  The 'ST' Monad+     ST,+     runST,+     fixST,+     -- *  Converting 'ST' to 'IO'+     RealWorld,+     stToIO+     ) where++import GHC.Internal.Control.Monad.ST
+ src/Control/Monad/ST/Lazy.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Monad.ST.Lazy+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires universal quantification for runST)+--+-- This module presents an identical interface to "Control.Monad.ST",+-- except that the monad delays evaluation of state operations until+-- a value depending on them is required.+--++module Control.Monad.ST.Lazy+    (-- *  The 'ST' monad+     ST,+     runST,+     fixST,+     -- *  Converting between strict and lazy 'ST'+     strictToLazyST,+     lazyToStrictST,+     -- *  Converting 'ST' To 'IO'+     RealWorld,+     stToIO+     ) where++import GHC.Internal.Control.Monad.ST.Lazy
+ src/Control/Monad/ST/Lazy/Safe.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Trustworthy #-}++-- |+--+-- Module      :  Control.Monad.ST.Lazy.Safe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires universal quantification for runST)+--+-- This module presents an identical interface to "Control.Monad.ST",+-- except that the monad delays evaluation of 'ST' operations until+-- a value depending on them is required.+--+-- Safe API only.+--++module Control.Monad.ST.Lazy.Safe+    {-# DEPRECATED "Safe is now the default, please use GHC.Internal.Control.Monad.ST.Lazy instead" #-}+    (-- *  The 'ST' monad+     ST,+     runST,+     fixST,+     -- *  Converting between strict and lazy 'ST'+     strictToLazyST,+     lazyToStrictST,+     -- *  Converting 'ST' To 'IO'+     RealWorld,+     stToIO+     ) where++import GHC.Internal.Control.Monad.ST.Lazy.Imp
+ src/Control/Monad/ST/Lazy/Unsafe.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Unsafe #-}++-- |+--+-- Module      :  Control.Monad.ST.Lazy.Unsafe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires universal quantification for runST)+--+-- This module presents an identical interface to "Control.Monad.ST",+-- except that the monad delays evaluation of 'ST' operations until+-- a value depending on them is required.+--+-- Unsafe API.+--++module Control.Monad.ST.Lazy.Unsafe+    (-- *  Unsafe operations+     unsafeInterleaveST,+     unsafeIOToST+     ) where++import GHC.Internal.Control.Monad.ST.Lazy.Imp
+ src/Control/Monad/ST/Safe.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Trustworthy #-}++-- |+--+-- Module      :  Control.Monad.ST.Safe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (requires universal quantification for runST)+--+-- This module provides support for /strict/ state threads, as+-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton+-- Jones /Lazy Functional State Threads/.+--+-- Safe API Only.+--++module Control.Monad.ST.Safe+    {-# DEPRECATED "Safe is now the default, please use GHC.Internal.Control.Monad.ST instead" #-}+    (-- *  The 'ST' Monad+     ST,+     runST,+     fixST,+     -- *  Converting 'ST' to 'IO'+     RealWorld,+     stToIO+     ) where++import GHC.Internal.Control.Monad.ST.Imp
+ src/Control/Monad/ST/Strict.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Control.Monad.ST.Strict+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires universal quantification for runST)+--+-- The strict ST monad (re-export of "Control.Monad.ST")+--++module Control.Monad.ST.Strict+    (module GHC.Internal.Control.Monad.ST) where++import GHC.Internal.Control.Monad.ST
+ src/Control/Monad/ST/Unsafe.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE Unsafe #-}++-- |+--+-- Module      :  Control.Monad.ST.Unsafe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (requires universal quantification for runST)+--+-- This module provides support for /strict/ state threads, as+-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton+-- Jones /Lazy Functional State Threads/.+--+-- Unsafe API.+--++module Control.Monad.ST.Unsafe+    (-- *  Unsafe operations+     unsafeInterleaveST,+     unsafeDupableInterleaveST,+     unsafeIOToST,+     unsafeSTToIO+     ) where++import GHC.Internal.Control.Monad.ST.Imp
+ src/Control/Monad/Zip.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Zip+-- Copyright   :  (c) Nils Schweinsberg 2011,+--                (c) George Giorgidze 2011+--                (c) University Tuebingen 2011+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Monadic zipping (used for monad comprehensions)+--+-----------------------------------------------------------------------------++module Control.Monad.Zip ( MonadZip(..) ) where++import GHC.Internal.Control.Monad.Zip(MonadZip(..))
+ src/Data/Array/Byte.hs view
@@ -0,0 +1,388 @@+-- |+-- Module      : Data.Array.Byte+-- Copyright   : (c) Roman Leshchinskiy 2009-2012+-- License     : BSD-style+--+-- Maintainer  : libraries@haskell.org+-- Portability : non-portable+--+-- Derived from @primitive@ package.++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Data.Array.Byte (+  ByteArray(..),+  MutableByteArray(..),+) where++import GHC.Internal.Data.Bits ((.&.), unsafeShiftR)+import GHC.Internal.Data.Data (mkNoRepType, Data(..))+import GHC.Internal.Data.Typeable (Typeable)+import qualified GHC.Internal.Data.Foldable as F+import GHC.Internal.Data.Maybe (fromMaybe)+import Data.Semigroup+import GHC.Internal.Exts+import GHC.Num.Integer (Integer(..))+import GHC.Internal.Show (intToDigit)+import GHC.Internal.ST (ST(..), runST)+import GHC.Internal.Word (Word8(..))+import GHC.Internal.TH.Syntax+import GHC.Internal.TH.Lift+import GHC.Internal.ForeignPtr+import Prelude++-- | Lifted wrapper for 'ByteArray#'.+--+-- Since 'ByteArray#' is an unlifted type and not a member of kind 'Data.Kind.Type',+-- things like @[ByteArray#]@ or @IO ByteArray#@ are ill-typed. To work around this+-- inconvenience this module provides a standard lifted wrapper, inhabiting 'Data.Kind.Type'.+-- Clients are expected to use 'ByteArray' in higher-level APIs,+-- but wrap and unwrap 'ByteArray' internally as they please+-- and use functions from "GHC.Exts".+--+-- The memory representation of a 'ByteArray' is:+--+-- > ╭─────────────┬───╮  ╭────────┬──────┬─────────╮+-- > │ Constructor │ * ┼─►│ Header │ Size │ Payload │+-- > ╰─────────────┴───╯  ╰────────┴──────┴─────────╯+--+-- And its overhead is the following:+--+-- * 'ByteArray' constructor: 1 word+-- * Pointer to 'ByteArray#': 1 word+-- * 'ByteArray#' Header: 1 word+-- * 'ByteArray#' Size: 1 word+--+-- Where a word is the unit of heap allocation,+-- measuring 8 bytes on 64-bit systems, and 4 bytes on 32-bit systems.+--+-- @since 4.17.0.0+data ByteArray = ByteArray ByteArray#++-- | Lifted wrapper for 'MutableByteArray#'.+--+-- Since 'MutableByteArray#' is an unlifted type and not a member of kind 'Data.Kind.Type',+-- things like @[MutableByteArray#]@ or @IO MutableByteArray#@ are ill-typed. To work around this+-- inconvenience this module provides a standard lifted wrapper, inhabiting 'Data.Kind.Type'.+-- Clients are expected to use 'MutableByteArray' in higher-level APIs,+-- but wrap and unwrap 'MutableByteArray' internally as they please+-- and use functions from "GHC.Exts".+--+-- @since 4.17.0.0+data MutableByteArray s = MutableByteArray (MutableByteArray# s)++-- | Create a new mutable byte array of the specified size in bytes.+--+-- /Note:/ this function does not check if the input is non-negative.+newByteArray :: Int -> ST s (MutableByteArray s)+{-# INLINE newByteArray #-}+newByteArray (I# n#) =+  ST (\s# -> case newByteArray# n# s# of+    (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))++-- | Convert a mutable byte array to an immutable one without copying. The+-- array should not be modified after the conversion.+unsafeFreezeByteArray :: MutableByteArray s -> ST s ByteArray+{-# INLINE unsafeFreezeByteArray #-}+unsafeFreezeByteArray (MutableByteArray arr#) =+  ST (\s# -> case unsafeFreezeByteArray# arr# s# of+    (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #))++-- | Size of the byte array in bytes.+sizeofByteArray :: ByteArray -> Int+{-# INLINE sizeofByteArray #-}+sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#)++-- | Read byte at specific index.+indexByteArray :: ByteArray -> Int -> Word8+{-# INLINE indexByteArray #-}+indexByteArray (ByteArray arr#) (I# i#) = W8# (indexWord8Array# arr# i#)++-- | Write byte at specific index.+writeByteArray :: MutableByteArray s -> Int -> Word8 -> ST s ()+{-# INLINE writeByteArray #-}+writeByteArray (MutableByteArray arr#) (I# i#) (W8# x#) =+  ST (\s# -> case writeWord8Array# arr# i# x# s# of+    s'# -> (# s'#, () #))++-- | Explode 'ByteArray' into a list of bytes.+byteArrayToList :: ByteArray -> [Word8]+{-# INLINE byteArrayToList #-}+byteArrayToList arr = go 0+  where+    go i+      | i < maxI  = indexByteArray arr i : go (i+1)+      | otherwise = []+    maxI = sizeofByteArray arr++-- | Create a 'ByteArray' from a list of a known length. If the length+--   of the list does not match the given length, this throws an exception.+byteArrayFromListN :: Int -> [Word8] -> ByteArray+byteArrayFromListN n ys+  | n >= 0 = runST $ do+    marr <- newByteArray n+    let go !ix [] = if ix == n+          then return ()+          else errorWithoutStackTrace $ "Data.Array.Byte.byteArrayFromListN: list length less than specified size"+        go !ix (x : xs) = if ix < n+          then do+            writeByteArray marr ix x+            go (ix + 1) xs+          else errorWithoutStackTrace $ "Data.Array.Byte.byteArrayFromListN: list length greater than specified size"+    go 0 ys+    unsafeFreezeByteArray marr+  | otherwise = errorWithoutStackTrace "Data.Array.Byte.ByteArrayFromListN: specified size is negative"++-- | Copy a slice of an immutable byte array to a mutable byte array.+--+-- /Note:/ this function does not do bounds or overlap checking.+unsafeCopyByteArray+  :: MutableByteArray s -- ^ destination array+  -> Int                -- ^ offset into destination array+  -> ByteArray          -- ^ source array+  -> Int                -- ^ offset into source array+  -> Int                -- ^ number of bytes to copy+  -> ST s ()+{-# INLINE unsafeCopyByteArray #-}+unsafeCopyByteArray (MutableByteArray dst#) (I# doff#) (ByteArray src#) (I# soff#) (I# sz#) =+  ST (\s# -> case copyByteArray# src# soff# dst# doff# sz# s# of+    s'# -> (# s'#, () #))++-- | Copy a slice from one mutable byte array to another+-- or to the same mutable byte array.+--+-- /Note:/ this function does not do bounds or overlap checking.+unsafeCopyMutableByteArray+  :: MutableByteArray s -- ^ destination array+  -> Int                -- ^ offset into destination array+  -> MutableByteArray s -- ^ source array+  -> Int                -- ^ offset into source array+  -> Int                -- ^ number of bytes to copy+  -> ST s ()+{-# INLINE unsafeCopyMutableByteArray #-}+unsafeCopyMutableByteArray (MutableByteArray dst#) (I# doff#) (MutableByteArray src#) (I# soff#) (I# sz#) =+  ST (\s# -> case copyMutableByteArrayNonOverlapping# src# soff# dst# doff# sz# s# of+    s'# -> (# s'#, () #))++-- | @since 4.17.0.0+instance Data ByteArray where+  toConstr _ = error "toConstr"+  gunfold _ _ = error "gunfold"+  dataTypeOf _ = mkNoRepType "Data.Array.Byte.ByteArray"++-- | @since 4.17.0.0+instance Typeable s => Data (MutableByteArray s) where+  toConstr _ = error "toConstr"+  gunfold _ _ = error "gunfold"+  dataTypeOf _ = mkNoRepType "Data.Array.Byte.MutableByteArray"++-- | @since 4.17.0.0+instance Show ByteArray where+  showsPrec _ ba =+      showString "[" . go 0+    where+      showW8 :: Word8 -> String -> String+      showW8 !w s =+          '0'+        : 'x'+        : intToDigit (fromIntegral (unsafeShiftR w 4))+        : intToDigit (fromIntegral (w .&. 0x0F))+        : s+      go i+        | i < sizeofByteArray ba = comma . showW8 (indexByteArray ba i :: Word8) . go (i+1)+        | otherwise              = showChar ']'+        where+          comma | i == 0    = id+                | otherwise = showString ", "++instance Lift ByteArray where+  liftTyped = unsafeCodeCoerce . lift+  lift (ByteArray b) =+    [| addrToByteArray $(lift len)+                       $(pure . LitE . BytesPrimL $ Bytes ptr 0 (fromIntegral len))+    |]+    where+      len# = sizeofByteArray# b+      len = I# len#+      pb :: ByteArray#+      !(ByteArray pb)+        | isTrue# (isByteArrayPinned# b) = ByteArray b+        | otherwise = runST $ ST $+          \s -> case newPinnedByteArray# len# s of+            (# s', mb #) -> case copyByteArray# b 0# mb 0# len# s' of+              s'' -> case unsafeFreezeByteArray# mb s'' of+                (# s''', ret #) -> (# s''', ByteArray ret #)+      ptr :: ForeignPtr Word8+      ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb))++{-# NOINLINE addrToByteArray #-}+addrToByteArray :: Int -> Addr# -> ByteArray+addrToByteArray (I# len) addr = runST $ ST $+  \s -> case newByteArray# len s of+    (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of+      s'' -> case unsafeFreezeByteArray# mb s'' of+        (# s''', ret #) -> (# s''', ByteArray ret #)++-- | Compare prefixes of given length.+compareByteArraysFromBeginning :: ByteArray -> ByteArray -> Int -> Ordering+{-# INLINE compareByteArraysFromBeginning #-}+compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#)+  = compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0++-- | Do two byte arrays share the same pointer?+sameByteArray :: ByteArray# -> ByteArray# -> Bool+sameByteArray ba1 ba2 =+    case sameByteArray# ba1 ba2 of r -> isTrue# r++-- | @since 4.17.0.0+instance Eq ByteArray where+  ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)+    | sameByteArray ba1# ba2# = True+    | n1 /= n2 = False+    | otherwise = compareByteArraysFromBeginning ba1 ba2 n1 == EQ+    where+      n1 = sizeofByteArray ba1+      n2 = sizeofByteArray ba2++-- | @since 4.17.0.0+instance Eq (MutableByteArray s) where+  (==) (MutableByteArray arr#) (MutableByteArray brr#)+    = isTrue# (sameMutableByteArray# arr# brr#)++-- | Non-lexicographic ordering. This compares the lengths of+-- the byte arrays first and uses a lexicographic ordering if+-- the lengths are equal. Subject to change between major versions.+--+-- @since 4.17.0.0+instance Ord ByteArray where+  ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#)+    | sameByteArray ba1# ba2# = EQ+    | n1 /= n2 = n1 `compare` n2+    | otherwise = compareByteArraysFromBeginning ba1 ba2 n1+    where+      n1 = sizeofByteArray ba1+      n2 = sizeofByteArray ba2+-- The primop compareByteArrays# (invoked from 'compareByteArraysFromBeginning')+-- performs a check for pointer equality as well. However, it+-- is included here because it is likely better to check for pointer equality+-- before checking for length equality. Getting the length requires deferencing+-- the pointers, which could cause accesses to memory that is not in the cache.+-- By contrast, a pointer equality check is always extremely cheap.++-- | Append two byte arrays.+appendByteArray :: ByteArray -> ByteArray -> ByteArray+appendByteArray ba1 ba2 = runST $ do+  let n1 = sizeofByteArray ba1+      n2 = sizeofByteArray ba2+      totSz = fromMaybe (sizeOverflowError "appendByteArray")+                        (checkedIntAdd n1 n2)+  marr <- newByteArray totSz+  unsafeCopyByteArray marr 0  ba1 0 n1+  unsafeCopyByteArray marr n1 ba2 0 n2+  unsafeFreezeByteArray marr++-- | Concatenate a list of 'ByteArray's.+concatByteArray :: [ByteArray] -> ByteArray+concatByteArray arrs = runST $ do+  let addLen acc arr = fromMaybe (sizeOverflowError "concatByteArray")+                                 (checkedIntAdd acc (sizeofByteArray arr))+      totLen = F.foldl' addLen 0 arrs+  marr <- newByteArray totLen+  pasteByteArrays marr 0 arrs+  unsafeFreezeByteArray marr++-- | Dump immutable 'ByteArray's into a mutable one, starting from a given offset.+pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s ()+pasteByteArrays !_ !_ [] = return ()+pasteByteArrays !marr !ix (x : xs) = do+  unsafeCopyByteArray marr ix x 0 (sizeofByteArray x)+  pasteByteArrays marr (ix + sizeofByteArray x) xs++-- | An array of zero length.+emptyByteArray :: ByteArray+emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray)++-- | Concatenates a given number of copies of an input ByteArray.+stimesPolymorphic :: Integral t => t -> ByteArray -> ByteArray+{-# INLINABLE stimesPolymorphic #-}+stimesPolymorphic nRaw !arr = case toInteger nRaw of+  IS nInt#+    | isTrue# (nInt# >#  0#) -> stimesPositiveInt (I# nInt#) arr+    | isTrue# (nInt# >=# 0#) -> emptyByteArray+      -- This check is redundant for unsigned types like Word.+      -- Using >=# intead of ==# may make it easier for GHC to notice that.+    | otherwise -> stimesNegativeErr+  IP _+    | sizeofByteArray arr == 0 -> emptyByteArray+    | otherwise -> stimesOverflowErr+  IN _ -> stimesNegativeErr++stimesNegativeErr :: ByteArray+stimesNegativeErr =+  errorWithoutStackTrace "stimes @ByteArray: negative multiplier"++stimesOverflowErr :: a+stimesOverflowErr = sizeOverflowError "stimes"++stimesPositiveInt :: Int -> ByteArray -> ByteArray+{-# NOINLINE stimesPositiveInt #-}+-- NOINLINE to prevent its duplication in specialisations of stimesPolymorphic+stimesPositiveInt n arr = runST $ do+  let inpSz = sizeofByteArray arr+      tarSz = fromMaybe stimesOverflowErr (checkedIntMultiply n inpSz)+  marr <- newByteArray tarSz+  unsafeCopyByteArray marr 0 arr 0 inpSz+  let+    halfTarSz = (tarSz - 1) `div` 2+    go copied+      | copied <= halfTarSz = do+          unsafeCopyMutableByteArray marr copied marr 0 copied+          go (copied + copied)+      | otherwise = unsafeCopyMutableByteArray marr copied marr 0 (tarSz - copied)+  go inpSz+  unsafeFreezeByteArray marr++-- | @since 4.17.0.0+instance Semigroup ByteArray where+  (<>) = appendByteArray+  sconcat = mconcat . F.toList+  {-# INLINE stimes #-}+  stimes = stimesPolymorphic++-- | @since 4.17.0.0+instance Monoid ByteArray where+  mempty = emptyByteArray+  mconcat = concatByteArray++-- | @since 4.17.0.0+instance IsList ByteArray where+  type Item ByteArray = Word8++  toList = byteArrayToList+  fromList xs = byteArrayFromListN (length xs) xs+  fromListN = byteArrayFromListN+++sizeOverflowError :: String -> a+sizeOverflowError fun+  = errorWithoutStackTrace $ "Data.Array.Byte." ++ fun ++ ": size overflow"+++-- TODO: Export these from a better home.++-- | Adds two @Int@s, returning @Nothing@ if this results in an overflow+checkedIntAdd :: Int -> Int -> Maybe Int+checkedIntAdd (I# x#) (I# y#) = case addIntC# x# y# of+  (# res, 0# #) -> Just (I# res)+  _ -> Nothing++-- | Multiplies two @Int@s, returning @Nothing@ if this results in an overflow+checkedIntMultiply :: Int -> Int -> Maybe Int+checkedIntMultiply (I# x#) (I# y#) = case timesInt2# x# y# of+  (# 0#, _hi, lo #) -> Just (I# lo)+  _ -> Nothing
+ src/Data/Bifoldable.hs view
@@ -0,0 +1,1054 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bifoldable+-- Copyright   :  (C) 2011-2016 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- @since 4.10.0.0+----------------------------------------------------------------------------+module Data.Bifoldable+  ( Bifoldable(..)+  , bifoldr'+  , bifoldr1+  , bifoldrM+  , bifoldl'+  , bifoldl1+  , bifoldlM+  , bitraverse_+  , bifor_+  , bimapM_+  , biforM_+  , bimsum+  , bisequenceA_+  , bisequence_+  , biasum+  , biList+  , binull+  , bilength+  , bielem+  , bimaximum+  , biminimum+  , bisum+  , biproduct+  , biconcat+  , biconcatMap+  , biand+  , bior+  , biany+  , biall+  , bimaximumBy+  , biminimumBy+  , binotElem+  , bifind+  ) where++import Control.Applicative+import GHC.Internal.Data.Functor.Utils (Max(..), Min(..), (#.))+import GHC.Internal.Data.Maybe (fromMaybe)+import GHC.Internal.Data.Monoid+import GHC.Generics (K1(..))+import Prelude++-- $setup+-- >>> import Prelude+-- >>> import Data.Char+-- >>> import GHC.Internal.Data.Monoid (Product (..), Sum (..))+-- >>> data BiList a b = BiList [a] [b]+-- >>> instance Bifoldable BiList where bifoldr f g z (BiList as bs) = foldr f (foldr g z bs) as++-- | 'Bifoldable' identifies foldable structures with two different varieties+-- of elements (as opposed to 'Foldable', which has one variety of element).+-- Common examples are 'Either' and @(,)@:+--+-- > instance Bifoldable Either where+-- >   bifoldMap f _ (Left  a) = f a+-- >   bifoldMap _ g (Right b) = g b+-- >+-- > instance Bifoldable (,) where+-- >   bifoldr f g z (a, b) = f a (g b z)+--+-- Some examples below also use the following BiList to showcase empty+-- Bifoldable behaviors when relevant ('Either' and '(,)' containing always exactly+-- resp. 1 and 2 elements):+--+-- > data BiList a b = BiList [a] [b]+-- >+-- > instance Bifoldable BiList where+-- >   bifoldr f g z (BiList as bs) = foldr f (foldr g z bs) as+--+-- A minimal 'Bifoldable' definition consists of either 'bifoldMap' or+-- 'bifoldr'. When defining more than this minimal set, one should ensure+-- that the following identities hold:+--+-- @+-- 'bifold' ≡ 'bifoldMap' 'id' 'id'+-- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'+-- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z+-- @+--+-- If the type is also an instance of 'Foldable', then+-- it must satisfy (up to laziness):+--+-- @+-- 'bifoldl' 'const' ≡ 'foldl'+-- 'bifoldr' ('flip' 'const') ≡ 'foldr'+-- 'bifoldMap' ('const' 'mempty') ≡ 'foldMap'+-- @+--+-- If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy:+--+-- @+-- 'bifoldMap' f g ≡ 'bifold' . 'Data.Bifunctor.bimap' f g+-- @+--+-- which implies that+--+-- @+-- 'bifoldMap' f g . 'Data.Bifunctor.bimap' h i ≡ 'bifoldMap' (f . h) (g . i)+-- @+--+-- @since 4.10.0.0+class Bifoldable p where+  {-# MINIMAL bifoldr | bifoldMap #-}++  -- | Combines the elements of a structure using a monoid.+  --+  -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@+  --+  -- ==== __Examples__+  --+  -- Basic usage:+  --+  -- >>> bifold (Right [1, 2, 3])+  -- [1,2,3]+  --+  -- >>> bifold (Left [5, 6])+  -- [5,6]+  --+  -- >>> bifold ([1, 2, 3], [4, 5])+  -- [1,2,3,4,5]+  --+  -- >>> bifold (Product 6, Product 7)+  -- Product {getProduct = 42}+  --+  -- >>> bifold (Sum 6, Sum 7)+  -- Sum {getSum = 13}+  --+  -- @since 4.10.0.0+  bifold :: Monoid m => p m m -> m+  bifold = bifoldMap id id++  -- | Combines the elements of a structure, given ways of mapping them to a+  -- common monoid.+  --+  -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@+  --+  -- ==== __Examples__+  --+  -- Basic usage:+  --+  -- >>> bifoldMap (take 3) (fmap digitToInt) ([1..], "89")+  -- [1,2,3,8,9]+  --+  -- >>> bifoldMap (take 3) (fmap digitToInt) (Left [1..])+  -- [1,2,3]+  --+  -- >>> bifoldMap (take 3) (fmap digitToInt) (Right "89")+  -- [8,9]+  --+  -- @since 4.10.0.0+  bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m+  bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty++  -- | Combines the elements of a structure in a right associative manner.+  -- Given a hypothetical function @toEitherList :: p a b -> [Either a b]@+  -- yielding a list of all elements of a structure in order, the following+  -- would hold:+  --+  -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@+  --+  -- ==== __Examples__+  --+  -- Basic usage:+  --+  -- @+  -- > bifoldr (+) (*) 3 (5, 7)+  -- 26 -- 5 + (7 * 3)+  --+  -- > bifoldr (+) (*) 3 (7, 5)+  -- 22 -- 7 + (5 * 3)+  --+  -- > bifoldr (+) (*) 3 (Right 5)+  -- 15 -- 5 * 3+  --+  -- > bifoldr (+) (*) 3 (Left 5)+  -- 8 -- 5 + 3+  -- @+  --+  -- @since 4.10.0.0+  bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c+  bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z++  -- | Combines the elements of a structure in a left associative manner. Given+  -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a+  -- list of all elements of a structure in order, the following would hold:+  --+  -- @'bifoldl' f g z+  --     ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@+  --+  -- Note that if you want an efficient left-fold, you probably want to use+  -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not+  -- force the "inner" results, resulting in a thunk chain which then must be+  -- evaluated from the outside-in.+  --+  -- ==== __Examples__+  --+  -- Basic usage:+  --+  -- @+  -- > bifoldl (+) (*) 3 (5, 7)+  -- 56 -- (5 + 3) * 7+  --+  -- > bifoldl (+) (*) 3 (7, 5)+  -- 50 -- (7 + 3) * 5+  --+  -- > bifoldl (+) (*) 3 (Right 5)+  -- 15 -- 5 * 3+  --+  -- > bifoldl (+) (*) 3 (Left 5)+  -- 8 -- 5 + 3+  -- @+  --+  -- @since 4.10.0.0+  bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c+  bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f)+                                                (Dual . Endo . flip g) t)) z++-- | Class laws for tuples hold only up to laziness. The+-- Bifoldable methods are lazier than their Foldable counterparts.+-- For example the law @'bifoldr' ('flip' 'const') ≡ 'foldr'@ does+-- not hold for tuples if laziness is exploited:+--+-- >>> bifoldr (flip const) (:) [] (undefined :: (Int, Word)) `seq` ()+-- ()+-- >>> foldr (:) [] (errorWithoutStackTrace "error!" :: (Int, Word)) `seq` ()+-- *** Exception: error!+--+-- @since 4.10.0.0+instance Bifoldable (,) where+  bifoldMap f g ~(a, b) = f a `mappend` g b++-- | @since 4.10.0.0+instance Bifoldable Const where+  bifoldMap f _ (Const a) = f a++-- | @since 4.10.0.0+instance Bifoldable (K1 i) where+  bifoldMap f _ (K1 c) = f c++-- | @since 4.10.0.0+instance Bifoldable ((,,) x) where+  bifoldMap f g ~(_,a,b) = f a `mappend` g b++-- | @since 4.10.0.0+instance Bifoldable ((,,,) x y) where+  bifoldMap f g ~(_,_,a,b) = f a `mappend` g b++-- | @since 4.10.0.0+instance Bifoldable ((,,,,) x y z) where+  bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b++-- | @since 4.10.0.0+instance Bifoldable ((,,,,,) x y z w) where+  bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b++-- | @since 4.10.0.0+instance Bifoldable ((,,,,,,) x y z w v) where+  bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b++-- | @since 4.10.0.0+instance Bifoldable Either where+  bifoldMap f _ (Left a) = f a+  bifoldMap _ g (Right b) = g b++-- | As 'bifoldr', but strict in the result of the reduction functions at each+-- step.+--+-- @since 4.10.0.0+bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c+bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where+  f' k x z = k $! f x z+  g' k x z = k $! g x z++-- | A variant of 'bifoldr' that has no base case,+-- and thus may only be applied to non-empty structures.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bifoldr1 (+) (5, 7)+-- 12+--+-- >>> bifoldr1 (+) (Right 7)+-- 7+--+-- >>> bifoldr1 (+) (Left 5)+-- 5+--+-- @+-- > bifoldr1 (+) (BiList [1, 2] [3, 4])+-- 10 -- 1 + (2 + (3 + 4))+-- @+--+-- >>> bifoldr1 (+) (BiList [1, 2] [])+-- 3+--+-- On empty structures, this function throws an exception:+--+-- >>> bifoldr1 (+) (BiList [] [])+-- *** Exception: bifoldr1: empty structure+-- ...+--+-- @since 4.10.0.0+bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a+bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure")+                  (bifoldr mbf mbf Nothing xs)+  where+    mbf x m = Just (case m of+                      Nothing -> x+                      Just y  -> f x y)++-- | Right associative monadic bifold over a structure.+--+-- @since 4.10.0.0+bifoldrM :: (Bifoldable t, Monad m)+         => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c+bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where+  f' k x z = f x z >>= k+  g' k x z = g x z >>= k++-- | As 'bifoldl', but strict in the result of the reduction functions at each+-- step.+--+-- This ensures that each step of the bifold 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 structure to+-- a single, monolithic result (e.g., 'bilength').+--+-- @since 4.10.0.0+bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a+bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where+  f' x k z = k $! f z x+  g' x k z = k $! g z x++-- | A variant of 'bifoldl' that has no base case,+-- and thus may only be applied to non-empty structures.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bifoldl1 (+) (5, 7)+-- 12+--+-- >>> bifoldl1 (+) (Right 7)+-- 7+--+-- >>> bifoldl1 (+) (Left 5)+-- 5+--+-- @+-- > bifoldl1 (+) (BiList [1, 2] [3, 4])+-- 10 -- ((1 + 2) + 3) + 4+-- @+--+-- >>> bifoldl1 (+) (BiList [1, 2] [])+-- 3+--+-- On empty structures, this function throws an exception:+--+-- >>> bifoldl1 (+) (BiList [] [])+-- *** Exception: bifoldl1: empty structure+-- ...+--+-- @since 4.10.0.0+bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a+bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure")+                  (bifoldl mbf mbf Nothing xs)+  where+    mbf m y = Just (case m of+                      Nothing -> y+                      Just x  -> f x y)++-- | Left associative monadic bifold over a structure.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 ("Hello", True)+-- "Hello"+-- "True"+-- 42+--+-- >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 (Right True)+-- "True"+-- 42+--+-- >>> bifoldlM (\a b -> print b >> pure a) (\a c -> print (show c) >> pure a) 42 (Left "Hello")+-- "Hello"+-- 42+--+-- @since 4.10.0.0+bifoldlM :: (Bifoldable t, Monad m)+         => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a+bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where+  f' x k z = f z x >>= k+  g' x k z = g z x >>= k++-- | Map each element of a structure using one of two actions, evaluate these+-- actions from left to right, and ignore the results. For a version that+-- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bitraverse_ print (print . show) ("Hello", True)+-- "Hello"+-- "True"+--+-- >>> bitraverse_ print (print . show) (Right True)+-- "True"+--+-- >>> bitraverse_ print (print . show) (Left "Hello")+-- "Hello"+--+-- @since 4.10.0.0+bitraverse_ :: (Bifoldable t, Applicative f)+            => (a -> f c) -> (b -> f d) -> t a b -> f ()+bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())++-- | As 'bitraverse_', but with the structure as the primary argument. For a+-- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bifor_ ("Hello", True) print (print . show)+-- "Hello"+-- "True"+--+-- >>> bifor_ (Right True) print (print . show)+-- "True"+--+-- >>> bifor_ (Left "Hello") print (print . show)+-- "Hello"+--+-- @since 4.10.0.0+bifor_ :: (Bifoldable t, Applicative f)+       => t a b -> (a -> f c) -> (b -> f d) -> f ()+bifor_ t f g = bitraverse_ f g t++-- | Alias for 'bitraverse_'.+--+-- @since 4.10.0.0+bimapM_ :: (Bifoldable t, Applicative f)+        => (a -> f c) -> (b -> f d) -> t a b -> f ()+bimapM_ = bitraverse_++-- | Alias for 'bifor_'.+--+-- @since 4.10.0.0+biforM_ :: (Bifoldable t, Applicative f)+        => t a b ->  (a -> f c) -> (b -> f d) -> f ()+biforM_ = bifor_++-- | Alias for 'bisequence_'.+--+-- @since 4.10.0.0+bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()+bisequenceA_ = bisequence_++-- | Evaluate each action in the structure from left to right, and ignore the+-- results. For a version that doesn't ignore the results, see+-- 'Data.Bitraversable.bisequence'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bisequence_ (print "Hello", print "World")+-- "Hello"+-- "World"+--+-- >>> bisequence_ (Left (print "Hello"))+-- "Hello"+--+-- >>> bisequence_ (Right (print "World"))+-- "World"+--+-- @since 4.10.0.0+bisequence_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()+bisequence_ = bifoldr (*>) (*>) (pure ())++-- | The sum of a collection of actions, generalizing 'biconcat'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biasum (Nothing, Nothing)+-- Nothing+--+-- >>> biasum (Nothing, Just 42)+-- Just 42+--+-- >>> biasum (Just 18, Nothing)+-- Just 18+--+-- >>> biasum (Just 18, Just 42)+-- Just 18+--+-- @since 4.10.0.0+biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a+biasum = bifoldr (<|>) (<|>) empty++-- | Alias for 'biasum'.+--+-- @since 4.10.0.0+bimsum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a+bimsum = biasum++-- | Collects the list of elements of a structure, from left to right.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biList (18, 42)+-- [18,42]+--+-- >>> biList (Left 18)+-- [18]+--+-- @since 4.10.0.0+biList :: Bifoldable t => t a a -> [a]+biList = bifoldr (:) (:) []++-- | Test whether the structure is empty.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> binull (18, 42)+-- False+--+-- >>> binull (Right 42)+-- False+--+-- >>> binull (BiList [] [])+-- True+--+-- @since 4.10.0.0+binull :: Bifoldable t => t a b -> Bool+binull = bifoldr (\_ _ -> False) (\_ _ -> False) True++-- | Returns the size/length of a finite structure as an 'Int'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bilength (True, 42)+-- 2+--+-- >>> bilength (Right 42)+-- 1+--+-- >>> bilength (BiList [1,2,3] [4,5])+-- 5+--+-- >>> bilength (BiList [] [])+-- 0+--+-- On infinite structures, this function hangs:+--+-- @+-- > bilength (BiList [1..] [])+-- * Hangs forever *+-- @+--+-- @since 4.10.0.0+bilength :: Bifoldable t => t a b -> Int+bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0++-- | Does the element occur in the structure?+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bielem 42 (17, 42)+-- True+--+-- >>> bielem 42 (17, 43)+-- False+--+-- >>> bielem 42 (Left 42)+-- True+--+-- >>> bielem 42 (Right 13)+-- False+--+-- >>> bielem 42 (BiList [1..5] [1..100])+-- True+--+-- >>> bielem 42 (BiList [1..5] [1..41])+-- False+--+-- @since 4.10.0.0+bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool+bielem x = biany (== x) (== x)++-- | Reduces a structure of lists to the concatenation of those lists.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biconcat ([1, 2, 3], [4, 5])+-- [1,2,3,4,5]+--+-- >>> biconcat (Left [1, 2, 3])+-- [1,2,3]+--+-- >>> biconcat (BiList [[1, 2, 3, 4, 5], [6, 7, 8]] [[9]])+-- [1,2,3,4,5,6,7,8,9]+--+-- @since 4.10.0.0+biconcat :: Bifoldable t => t [a] [a] -> [a]+biconcat = bifold++-- | The largest element of a non-empty structure. This function is equivalent+-- to @'bifoldr1' 'max'@, and its behavior on structures with multiple largest+-- elements depends on the relevant implementation of 'max'. For the default+-- implementation of 'max' (@max x y = if x <= y then y else x@), structure+-- order is used as a tie-breaker: if there are multiple largest elements, the+-- rightmost of them is chosen (this is equivalent to @'bimaximumBy'+-- 'compare'@).+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bimaximum (42, 17)+-- 42+--+-- >>> bimaximum (Right 42)+-- 42+--+-- >>> bimaximum (BiList [13, 29, 4] [18, 1, 7])+-- 29+--+-- >>> bimaximum (BiList [13, 29, 4] [])+-- 29+--+-- On empty structures, this function throws an exception:+--+-- >>> bimaximum (BiList [] [])+-- *** Exception: bimaximum: empty structure+-- ...+--+-- @since 4.10.0.0+bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a+bimaximum = fromMaybe (error "bimaximum: empty structure") .+    getMax . bifoldMap mj mj+  where mj = Max #. (Just :: a -> Maybe a)++-- | The least element of a non-empty structure. This function is equivalent to+-- @'bifoldr1' 'min'@, and its behavior on structures with multiple least+-- elements depends on the relevant implementation of 'min'. For the default+-- implementation of 'min' (@min x y = if x <= y then x else y@), structure+-- order is used as a tie-breaker: if there are multiple least elements, the+-- leftmost of them is chosen (this is equivalent to @'biminimumBy'+-- 'compare'@).+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biminimum (42, 17)+-- 17+--+-- >>> biminimum (Right 42)+-- 42+--+-- >>> biminimum (BiList [13, 29, 4] [18, 1, 7])+-- 1+--+-- >>> biminimum (BiList [13, 29, 4] [])+-- 4+--+-- On empty structures, this function throws an exception:+--+-- >>> biminimum (BiList [] [])+-- *** Exception: biminimum: empty structure+-- ...+--+-- @since 4.10.0.0+biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a+biminimum = fromMaybe (error "biminimum: empty structure") .+    getMin . bifoldMap mj mj+  where mj = Min #. (Just :: a -> Maybe a)++-- | The 'bisum' function computes the sum of the numbers of a structure.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bisum (42, 17)+-- 59+--+-- >>> bisum (Right 42)+-- 42+--+-- >>> bisum (BiList [13, 29, 4] [18, 1, 7])+-- 72+--+-- >>> bisum (BiList [13, 29, 4] [])+-- 46+--+-- >>> bisum (BiList [] [])+-- 0+--+-- @since 4.10.0.0+bisum :: (Bifoldable t, Num a) => t a a -> a+bisum = getSum #. bifoldMap Sum Sum++-- | The 'biproduct' function computes the product of the numbers of a+-- structure.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biproduct (42, 17)+-- 714+--+-- >>> biproduct (Right 42)+-- 42+--+-- >>> biproduct (BiList [13, 29, 4] [18, 1, 7])+-- 190008+--+-- >>> biproduct (BiList [13, 29, 4] [])+-- 1508+--+-- >>> biproduct (BiList [] [])+-- 1+--+-- @since 4.10.0.0+biproduct :: (Bifoldable t, Num a) => t a a -> a+biproduct = getProduct #. bifoldMap Product Product++-- | Given a means of mapping the elements of a structure to lists, computes the+-- concatenation of all such lists in order.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biconcatMap (take 3) (fmap digitToInt) ([1..], "89")+-- [1,2,3,8,9]+--+-- >>> biconcatMap (take 3) (fmap digitToInt) (Left [1..])+-- [1,2,3]+--+-- >>> biconcatMap (take 3) (fmap digitToInt) (Right "89")+-- [8,9]+--+-- @since 4.10.0.0+biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c]+biconcatMap = bifoldMap++-- | 'biand' returns the conjunction of a container of Bools.  For the+-- result to be 'True', the container must be finite; 'False', however,+-- results from a 'False' value finitely far from the left end.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biand (True, False)+-- False+--+-- >>> biand (True, True)+-- True+--+-- >>> biand (Left True)+-- True+--+-- Empty structures yield 'True':+--+-- >>> biand (BiList [] [])+-- True+--+-- A 'False' value finitely far from the left end yields 'False' (short circuit):+--+-- >>> biand (BiList [True, True, False, True] (repeat True))+-- False+--+-- A 'False' value infinitely far from the left end hangs:+--+-- @+-- > biand (BiList (repeat True) [False])+-- * Hangs forever *+-- @+--+-- An infinitely 'True' value hangs:+--+-- @+-- > biand (BiList (repeat True) [])+-- * Hangs forever *+-- @+--+-- @since 4.10.0.0+biand :: Bifoldable t => t Bool Bool -> Bool+biand = getAll #. bifoldMap All All++-- | 'bior' returns the disjunction of a container of Bools.  For the+-- result to be 'False', the container must be finite; 'True', however,+-- results from a 'True' value finitely far from the left end.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bior (True, False)+-- True+--+-- >>> bior (False, False)+-- False+--+-- >>> bior (Left True)+-- True+--+-- Empty structures yield 'False':+--+-- >>> bior (BiList [] [])+-- False+--+-- A 'True' value finitely far from the left end yields 'True' (short circuit):+--+-- >>> bior (BiList [False, False, True, False] (repeat False))+-- True+--+-- A 'True' value infinitely far from the left end hangs:+--+-- @+-- > bior (BiList (repeat False) [True])+-- * Hangs forever *+-- @+--+-- An infinitely 'False' value hangs:+--+-- @+-- > bior (BiList (repeat False) [])+-- * Hangs forever *+-- @+--+-- @since 4.10.0.0+bior :: Bifoldable t => t Bool Bool -> Bool+bior = getAny #. bifoldMap Any Any++-- | Determines whether any element of the structure satisfies its appropriate+-- predicate argument. Empty structures yield 'False'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biany even isDigit (27, 't')+-- False+--+-- >>> biany even isDigit (27, '8')+-- True+--+-- >>> biany even isDigit (26, 't')+-- True+--+-- >>> biany even isDigit (Left 27)+-- False+--+-- >>> biany even isDigit (Left 26)+-- True+--+-- >>> biany even isDigit (BiList [27, 53] ['t', '8'])+-- True+--+-- Empty structures yield 'False':+--+-- >>> biany even isDigit (BiList [] [])+-- False+--+-- @since 4.10.0.0+biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool+biany p q = getAny #. bifoldMap (Any . p) (Any . q)++-- | Determines whether all elements of the structure satisfy their appropriate+-- predicate argument. Empty structures yield 'True'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biall even isDigit (27, 't')+-- False+--+-- >>> biall even isDigit (26, '8')+-- True+--+-- >>> biall even isDigit (Left 27)+-- False+--+-- >>> biall even isDigit (Left 26)+-- True+--+-- >>> biall even isDigit (BiList [26, 52] ['3', '8'])+-- True+--+-- Empty structures yield 'True':+--+-- >>> biall even isDigit (BiList [] [])+-- True+--+-- @since 4.10.0.0+biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool+biall p q = getAll #. bifoldMap (All . p) (All . q)++-- | The largest element of a non-empty structure with respect to the+-- given comparison function. Structure order is used as a tie-breaker: if+-- there are multiple largest elements, the rightmost of them is chosen.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bimaximumBy compare (42, 17)+-- 42+--+-- >>> bimaximumBy compare (Left 17)+-- 17+--+-- >>> bimaximumBy compare (BiList [42, 17, 23] [-5, 18])+-- 42+--+-- On empty structures, this function throws an exception:+--+-- >>> bimaximumBy compare (BiList [] [])+-- *** Exception: bifoldr1: empty structure+-- ...+--+-- @since 4.10.0.0+bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a+bimaximumBy cmp = bifoldr1 max'+  where max' x y = case cmp x y of+                        GT -> x+                        _  -> y++-- | The least element of a non-empty structure with respect to the+-- given comparison function. Structure order is used as a tie-breaker: if+-- there are multiple least elements, the leftmost of them is chosen.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> biminimumBy compare (42, 17)+-- 17+--+-- >>> biminimumBy compare (Left 17)+-- 17+--+-- >>> biminimumBy compare (BiList [42, 17, 23] [-5, 18])+-- -5+--+-- On empty structures, this function throws an exception:+--+-- >>> biminimumBy compare (BiList [] [])+-- *** Exception: bifoldr1: empty structure+-- ...+--+-- @since 4.10.0.0+biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a+biminimumBy cmp = bifoldr1 min'+  where min' x y = case cmp x y of+                        GT -> y+                        _  -> x++-- | 'binotElem' is the negation of 'bielem'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> binotElem 42 (17, 42)+-- False+--+-- >>> binotElem 42 (17, 43)+-- True+--+-- >>> binotElem 42 (Left 42)+-- False+--+-- >>> binotElem 42 (Right 13)+-- True+--+-- >>> binotElem 42 (BiList [1..5] [1..100])+-- False+--+-- >>> binotElem 42 (BiList [1..5] [1..41])+-- True+--+-- @since 4.10.0.0+binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool+binotElem x =  not . bielem x++-- | The 'bifind' function takes a predicate and a structure and returns+-- the leftmost element of the structure matching the predicate, or+-- 'Nothing' if there is no such element.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bifind even (27, 53)+-- Nothing+--+-- >>> bifind even (27, 52)+-- Just 52+--+-- >>> bifind even (26, 52)+-- Just 26+--+-- Empty structures always yield 'Nothing':+--+-- >>> bifind even (BiList [] [])+-- Nothing+--+-- @since 4.10.0.0+bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a+bifind p = getFirst . bifoldMap finder finder+  where finder x = First (if p x then Just x else Nothing)
+ src/Data/Bifoldable1.hs view
@@ -0,0 +1,49 @@+-- |+-- Copyright: Edward Kmett, Oleg Grenrus+-- License: BSD-3-Clause+--++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Safe              #-}++module Data.Bifoldable1 where++import Control.Applicative (Const (..))+import Data.Bifoldable     (Bifoldable (..))+import Data.Semigroup      (Arg (..), Semigroup (..))+import Prelude             (Either (..), id)++class Bifoldable t => Bifoldable1 t where+     bifold1 :: Semigroup m => t m m -> m+     bifold1 = bifoldMap1 id id+     {-# INLINE bifold1 #-}++     bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m++instance Bifoldable1 Arg where+    bifoldMap1 f g (Arg a b) = f a <> g b++instance Bifoldable1 Either where+    bifoldMap1 f _ (Left a) = f a+    bifoldMap1 _ g (Right b) = g b+    {-# INLINE bifoldMap1 #-}++instance Bifoldable1 (,) where+    bifoldMap1 f g (a, b) = f a <> g b+    {-# INLINE bifoldMap1 #-}++instance Bifoldable1 ((,,) x) where+    bifoldMap1 f g (_,a,b) = f a <> g b+    {-# INLINE bifoldMap1 #-}++instance Bifoldable1 ((,,,) x y) where+    bifoldMap1 f g (_,_,a,b) = f a <> g b+    {-# INLINE bifoldMap1 #-}++instance Bifoldable1 ((,,,,) x y z) where+    bifoldMap1 f g (_,_,_,a,b) = f a <> g b+    {-# INLINE bifoldMap1 #-}++instance Bifoldable1 Const where+    bifoldMap1 f _ (Const a) = f a+    {-# INLINE bifoldMap1 #-}
+ src/Data/Bifunctor.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bifunctor+-- Copyright   :  (C) 2008-2014 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- @since 4.8.0.0+----------------------------------------------------------------------------+module Data.Bifunctor+  ( Bifunctor(..)+  ) where++import Control.Applicative  ( Const(..) )+import GHC.Generics ( K1(..) )+import Prelude++-- $setup+-- >>> import Prelude+-- >>> import Data.Char (toUpper)++-- | A bifunctor is a type constructor that takes+-- two type arguments and is a functor in /both/ arguments. That+-- is, unlike with 'Functor', a type constructor such as 'Either'+-- does not need to be partially applied for a 'Bifunctor'+-- instance, and the methods in this class permit mapping+-- functions over the 'Left' value or the 'Right' value,+-- or both at the same time.+--+-- Formally, the class 'Bifunctor' represents a bifunctor+-- from @Hask@ -> @Hask@.+--+-- Intuitively it is a bifunctor where both the first and second+-- arguments are covariant.+--+-- The class definition of a 'Bifunctor' @p@ uses the+-- [QuantifiedConstraints](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/quantified_constraints.html)+-- language extension to quantify over the first type+-- argument @a@ in its context. The context requires that @p a@+-- must be a 'Functor' for all @a@. In other words a partially+-- applied 'Bifunctor' must be a 'Functor'. This makes 'Functor' a+-- superclass of 'Bifunctor' such that a function with a+-- 'Bifunctor' constraint may use 'fmap' in its implementation.+-- 'Functor' has been a quantified superclass of+-- 'Bifunctor' since base-4.18.0.0.+--+-- You can define a 'Bifunctor' by either defining 'bimap' or by+-- defining both 'first' and 'second'. The 'second' method must+-- agree with 'fmap':+--+-- @'second' ≡ 'fmap'@+--+-- From this it follows that:+--+-- @'second' 'id' ≡ 'id'@+--+-- If you supply 'bimap', you should ensure that:+--+-- @'bimap' 'id' 'id' ≡ 'id'@+--+-- If you supply 'first' and 'second', ensure:+--+-- @+-- 'first' 'id' ≡ 'id'+-- 'second' 'id' ≡ 'id'+-- @+--+-- If you supply both, you should also ensure:+--+-- @'bimap' f g ≡ 'first' f '.' 'second' g@+--+-- These ensure by parametricity:+--+-- @+-- 'bimap'  (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i+-- 'first'  (f '.' g) ≡ 'first'  f '.' 'first'  g+-- 'second' (f '.' g) ≡ 'second' f '.' 'second' g+-- @+--+-- @since 4.8.0.0+class (forall a. Functor (p a)) => Bifunctor p where+    {-# MINIMAL bimap | first, second #-}++    -- | Map over both arguments at the same time.+    --+    -- @'bimap' f g ≡ 'first' f '.' 'second' g@+    --+    -- ==== __Examples__+    -- >>> bimap toUpper (+1) ('j', 3)+    -- ('J',4)+    --+    -- >>> bimap toUpper (+1) (Left 'j')+    -- Left 'J'+    --+    -- >>> bimap toUpper (+1) (Right 3)+    -- Right 4+    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d+    bimap f g = first f . second g+++    -- | Map covariantly over the first argument.+    --+    -- @'first' f ≡ 'bimap' f 'id'@+    --+    -- ==== __Examples__+    -- >>> first toUpper ('j', 3)+    -- ('J',3)+    --+    -- >>> first toUpper (Left 'j')+    -- Left 'J'+    first :: (a -> b) -> p a c -> p b c+    first f = bimap f id+++    -- | Map covariantly over the second argument.+    --+    -- @'second' ≡ 'bimap' 'id'@+    --+    -- ==== __Examples__+    -- >>> second (+1) ('j', 3)+    -- ('j',4)+    --+    -- >>> second (+1) (Right 3)+    -- Right 4+    second :: (b -> c) -> p a b -> p a c+    second = bimap id+++-- | Class laws for tuples hold only up to laziness. Both+-- 'first' 'id' and 'second' 'id' are lazier than 'id' (and 'fmap' 'id'):+--+-- >>> first id (undefined :: (Int, Word)) `seq` ()+-- ()+-- >>> second id (undefined :: (Int, Word)) `seq` ()+-- ()+-- >>> id (errorWithoutStackTrace "error!" :: (Int, Word)) `seq` ()+-- *** Exception: error!+--+-- @since 4.8.0.0+instance Bifunctor (,) where+    bimap f g ~(a, b) = (f a, g b)++-- | @since 4.8.0.0+instance Bifunctor ((,,) x1) where+    bimap f g ~(x1, a, b) = (x1, f a, g b)++-- | @since 4.8.0.0+instance Bifunctor ((,,,) x1 x2) where+    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)++-- | @since 4.8.0.0+instance Bifunctor ((,,,,) x1 x2 x3) where+    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)++-- | @since 4.8.0.0+instance Bifunctor ((,,,,,) x1 x2 x3 x4) where+    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)++-- | @since 4.8.0.0+instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where+    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)+++-- | @since 4.8.0.0+instance Bifunctor Either where+    bimap f _ (Left a) = Left (f a)+    bimap _ g (Right b) = Right (g b)++-- | @since 4.8.0.0+instance Bifunctor Const where+    bimap f _ (Const a) = Const (f a)++-- | @since 4.9.0.0+instance Bifunctor (K1 i) where+    bimap f _ (K1 c) = K1 (f c)
+ src/Data/Bitraversable.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bitraversable+-- Copyright   :  (C) 2011-2016 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- @since 4.10.0.0+----------------------------------------------------------------------------+module Data.Bitraversable+  ( Bitraversable(..)+  , bisequenceA+  , bisequence+  , bimapM+  , firstA+  , secondA+  , bifor+  , biforM+  , bimapAccumL+  , bimapAccumR+  , bimapDefault+  , bifoldMapDefault+  ) where++import Control.Applicative+import Data.Bifunctor+import Data.Bifoldable+import GHC.Internal.Data.Coerce+import GHC.Internal.Data.Functor.Identity (Identity(..))+import GHC.Internal.Data.Functor.Utils (StateL(..), StateR(..))+import GHC.Generics (K1(..))+import Prelude++-- $setup+-- >>> import Prelude+-- >>> import GHC.Internal.Data.Maybe+-- >>> import GHC.Internal.Data.List (find)++-- | 'Bitraversable' identifies bifunctorial data structures whose elements can+-- be traversed in order, performing 'Applicative' or 'Monad' actions at each+-- element, and collecting a result structure with the same shape.+--+-- As opposed to 'Traversable' data structures, which have one variety of+-- element on which an action can be performed, 'Bitraversable' data structures+-- have two such varieties of elements.+--+-- A definition of 'bitraverse' must satisfy the following laws:+--+-- [Naturality]+--   @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@+--   for every applicative transformation @t@+--+-- [Identity]+--   @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@+--+-- [Composition]+--   @'Data.Functor.Compose.Compose' .+--    'fmap' ('bitraverse' g1 g2) .+--    'bitraverse' f1 f2+--     ≡ 'bitraverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1)+--                  ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@+--+-- where an /applicative transformation/ is a function+--+-- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@+--+-- preserving the 'Applicative' operations:+--+-- @+-- t ('pure' x) ≡ 'pure' x+-- t (f '<*>' x) ≡ t f '<*>' t x+-- @+--+-- and the identity functor 'Identity' and composition functors+-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and+-- "Data.Functor.Compose".+--+-- Some simple examples are 'Either' and @(,)@:+--+-- > instance Bitraversable Either where+-- >   bitraverse f _ (Left x) = Left <$> f x+-- >   bitraverse _ g (Right y) = Right <$> g y+-- >+-- > instance Bitraversable (,) where+-- >   bitraverse f g (x, y) = (,) <$> f x <*> g y+--+-- 'Bitraversable' relates to its superclasses in the following ways:+--+-- @+-- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)+-- 'bifoldMap' f g ≡ 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)+-- @+--+-- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.+--+-- If the type is also an instance of 'Traversable', then+-- it must satisfy (up to laziness):+--+-- @+-- 'traverse' ≡ 'bitraverse' 'pure'+-- @+--+-- @since 4.10.0.0+class (Bifunctor t, Bifoldable t) => Bitraversable t where+  -- | Evaluates the relevant functions at each element in the structure,+  -- running the action, and builds a new structure with the same shape, using+  -- the results produced from sequencing the actions.+  --+  -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@+  --+  -- For a version that ignores the results, see 'bitraverse_'.+  --+  -- ==== __Examples__+  --+  -- Basic usage:+  --+  -- >>> bitraverse listToMaybe (find odd) (Left [])+  -- Nothing+  --+  -- >>> bitraverse listToMaybe (find odd) (Left [1, 2, 3])+  -- Just (Left 1)+  --+  -- >>> bitraverse listToMaybe (find odd) (Right [4, 5])+  -- Just (Right 5)+  --+  -- >>> bitraverse listToMaybe (find odd) ([1, 2, 3], [4, 5])+  -- Just (1,5)+  --+  -- >>> bitraverse listToMaybe (find odd) ([], [4, 5])+  -- Nothing+  --+  -- @since 4.10.0.0+  bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)++-- | Alias for 'bisequence'.+--+-- @since 4.10.0.0+bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)+bisequenceA = bisequence++-- | Alias for 'bitraverse'.+--+-- @since 4.10.0.0+bimapM :: (Bitraversable t, Applicative f)+       => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)+bimapM = bitraverse++-- | Sequences all the actions in a structure, building a new structure with+-- the same shape using the results of the actions. For a version that ignores+-- the results, see 'bisequence_'.+--+-- @'bisequence' ≡ 'bitraverse' 'id' 'id'@+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bisequence (Just 4, Nothing)+-- Nothing+--+-- >>> bisequence (Just 4, Just 5)+-- Just (4,5)+--+-- >>> bisequence ([1, 2, 3], [4, 5])+-- [(1,4),(1,5),(2,4),(2,5),(3,4),(3,5)]+--+-- @since 4.10.0.0+bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)+bisequence = bitraverse id id++-- | Traverses only over the first argument.+--+-- @'firstA' f ≡ 'bitraverse' f 'pure'@++-- ==== __Examples__+--+-- Basic usage:+--+-- >>> firstA listToMaybe (Left [])+-- Nothing+--+-- >>> firstA listToMaybe (Left [1, 2, 3])+-- Just (Left 1)+--+-- >>> firstA listToMaybe (Right [4, 5])+-- Just (Right [4, 5])+--+-- >>> firstA listToMaybe ([1, 2, 3], [4, 5])+-- Just (1,[4, 5])+--+-- >>> firstA listToMaybe ([], [4, 5])+-- Nothing++-- @since 4.21.0.0+firstA :: Bitraversable t => Applicative f => (a -> f c) -> t a b -> f (t c b)+firstA f = bitraverse f pure++-- | Traverses only over the second argument.+--+-- @'secondA' f ≡ 'bitraverse' 'pure' f@+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> secondA (find odd) (Left [])+-- Just (Left [])+--+-- >>> secondA (find odd) (Left [1, 2, 3])+-- Just (Left [1,2,3])+--+-- >>> secondA (find odd) (Right [4, 5])+-- Just (Right 5)+--+-- >>> secondA (find odd) ([1, 2, 3], [4, 5])+-- Just ([1,2,3],5)+--+-- >>> secondA (find odd) ([1,2,3], [4])+-- Nothing+--+-- @since 4.21.0.0+secondA :: Bitraversable t => Applicative f => (b -> f c) -> t a b -> f (t a c)+secondA f = bitraverse pure f++-- | Class laws for tuples hold only up to laziness. The+-- Bitraversable methods are lazier than their Traversable counterparts.+-- For example the law @'bitraverse' 'pure' ≡ 'traverse'@ does+-- not hold for tuples if laziness is exploited:+--+-- >>> (bitraverse pure pure undefined :: IO (Int, Word)) `seq` ()+-- ()+-- >>> (traverse pure (errorWithoutStackTrace "error!") :: IO (Int, Word)) `seq` ()+-- *** Exception: error!+--+-- @since 4.10.0.0+instance Bitraversable (,) where+  bitraverse f g ~(a, b) = liftA2 (,) (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable ((,,) x) where+  bitraverse f g ~(x, a, b) = liftA2 ((,,) x) (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable ((,,,) x y) where+  bitraverse f g ~(x, y, a, b) = liftA2 ((,,,) x y) (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable ((,,,,) x y z) where+  bitraverse f g ~(x, y, z, a, b) = liftA2 ((,,,,) x y z) (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable ((,,,,,) x y z w) where+  bitraverse f g ~(x, y, z, w, a, b) = liftA2 ((,,,,,) x y z w) (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable ((,,,,,,) x y z w v) where+  bitraverse f g ~(x, y, z, w, v, a, b) =+    liftA2 ((,,,,,,) x y z w v) (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable Either where+  bitraverse f _ (Left a) = Left <$> f a+  bitraverse _ g (Right b) = Right <$> g b++-- | @since 4.10.0.0+instance Bitraversable Const where+  bitraverse f _ (Const a) = Const <$> f a++-- | @since 4.10.0.0+instance Bitraversable (K1 i) where+  bitraverse f _ (K1 c) = K1 <$> f c++-- | 'bifor' is 'bitraverse' with the structure as the first argument. For a+-- version that ignores the results, see 'bifor_'.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bifor (Left []) listToMaybe (find even)+-- Nothing+--+-- >>> bifor (Left [1, 2, 3]) listToMaybe (find even)+-- Just (Left 1)+--+-- >>> bifor (Right [4, 5]) listToMaybe (find even)+-- Just (Right 4)+--+-- >>> bifor ([1, 2, 3], [4, 5]) listToMaybe (find even)+-- Just (1,4)+--+-- >>> bifor ([], [4, 5]) listToMaybe (find even)+-- Nothing+--+-- @since 4.10.0.0+bifor :: (Bitraversable t, Applicative f)+      => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)+bifor t f g = bitraverse f g t++-- | Alias for 'bifor'.+--+-- @since 4.10.0.0+biforM :: (Bitraversable t, Applicative f)+       => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)+biforM = bifor++-- | The 'bimapAccumL' function behaves like a combination of 'bimap' and+-- 'bifoldl'; it traverses a structure from left to right, threading a state+-- of type @a@ and using the given actions to compute new elements for the+-- structure.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bimapAccumL (\acc bool -> (acc + 1, show bool)) (\acc string -> (acc * 2, reverse string)) 3 (True, "foo")+-- (8,("True","oof"))+--+-- @since 4.10.0.0+bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))+            -> a -> t b d -> (a, t c e)+bimapAccumL f g s t+  = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s++-- | The 'bimapAccumR' function behaves like a combination of 'bimap' and+-- 'bifoldr'; it traverses a structure from right to left, threading a state+-- of type @a@ and using the given actions to compute new elements for the+-- structure.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> bimapAccumR (\acc bool -> (acc + 1, show bool)) (\acc string -> (acc * 2, reverse string)) 3 (True, "foo")+-- (7,("True","oof"))+--+-- @since 4.10.0.0+bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))+            -> a -> t b d -> (a, t c e)+bimapAccumR f g s t+  = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s++-- | A default definition of 'bimap' in terms of the 'Bitraversable'+-- operations.+--+-- @'bimapDefault' f g ≡+--     'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@+--+-- @since 4.10.0.0+bimapDefault :: forall t a b c d . Bitraversable t+             => (a -> b) -> (c -> d) -> t a c -> t b d+-- See Note [Function coercion] in Data.Functor.Utils.+bimapDefault = coerce+  (bitraverse :: (a -> Identity b)+              -> (c -> Identity d) -> t a c -> Identity (t b d))+{-# INLINE bimapDefault #-}++-- | A default definition of 'bifoldMap' in terms of the 'Bitraversable'+-- operations.+--+-- @'bifoldMapDefault' f g ≡+--    'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@+--+-- @since 4.10.0.0+bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)+                 => (a -> m) -> (b -> m) -> t a b -> m+-- See Note [Function coercion] in Data.Functor.Utils.+bifoldMapDefault = coerce+  (bitraverse :: (a -> Const m ())+              -> (b -> Const m ()) -> t a b -> Const m (t () ()))+{-# INLINE bifoldMapDefault #-}
+ src/Data/Bits.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Bits+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- This module defines bitwise operations for signed and unsigned+-- integers.  Instances of the class 'Bits' for the 'Int' and+-- 'Integer' types are available from this module, and instances for+-- explicitly sized integral types are available from the+-- "Data.Int" and "Data.Word" modules.+--++module Data.Bits+    (-- *  Type classes+     Bits((.&.), (.|.), xor, complement, shift, rotate, zeroBits, bit, setBit, clearBit, complementBit, testBit, bitSizeMaybe, bitSize, isSigned, shiftL, shiftR, unsafeShiftL, unsafeShiftR, rotateL, rotateR, popCount),+     FiniteBits(finiteBitSize, countLeadingZeros, countTrailingZeros),+     -- *  Extra functions+     bitDefault,+     testBitDefault,+     popCountDefault,+     toIntegralSized,+     oneBits,+     (.^.),+     (.>>.),+     (.<<.),+     (!>>.),+     (!<<.),+     -- *  Newtypes+     And(..),+     Ior(..),+     Xor(..),+     Iff(..)+     ) where++import GHC.Internal.Data.Bits
+ src/Data/Bool.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Bool+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The 'Bool' type and related functions.+--++module Data.Bool+    (-- *  Booleans+     Bool(..),+     -- **  Operations+     (&&),+     (||),+     not,+     otherwise,+     bool+     ) where++import GHC.Internal.Data.Bool
+ src/Data/Bounded.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bounded+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (GHC extensions)+--+-- The 'Bounded' class.+--+-- @since 4.21.0.0+--+-----------------------------------------------------------------------------++module Data.Bounded+    ( Bounded(..)+    ) where++import GHC.Enum+
+ src/Data/Char.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE NoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Char+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Char type and associated operations.+--+-----------------------------------------------------------------------------++module Data.Char+    (+      Char++    -- * Character classification+    -- | Unicode characters are divided into letters, numbers, marks,+    -- punctuation, symbols, separators (including spaces) and others+    -- (including control characters).+    , isControl, isSpace+    , isLower, isLowerCase, isUpper, isUpperCase, isAlpha, isAlphaNum, isPrint+    , isDigit, isOctDigit, isHexDigit+    , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator++    -- ** Subranges+    , isAscii, isLatin1+    , isAsciiUpper, isAsciiLower++    -- ** Unicode general categories+    , GeneralCategory(..), generalCategory++    -- * Case conversion+    , toUpper, toLower, toTitle++    -- * Single digit characters+    , digitToInt+    , intToDigit++    -- * Numeric representations+    , ord+    , chr++    -- * String representations+    , showLitChar+    , lexLitChar+    , readLitChar+    ) where++import GHC.Internal.Base+import GHC.Internal.Char+import GHC.Internal.Real (fromIntegral)+import GHC.Internal.Show+import GHC.Internal.Read (readLitChar, lexLitChar)+import GHC.Internal.Unicode+import GHC.Internal.Num++-- $setup+-- Allow the use of Prelude in doctests.+-- >>> import Prelude++-- | Convert a single digit 'Char' to the corresponding 'Int'.  This+-- function fails unless its argument satisfies 'isHexDigit', but+-- recognises both upper- and lower-case hexadecimal digits (that+-- is, @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).+--+-- ==== __Examples__+--+-- Characters @\'0\'@ through @\'9\'@ are converted properly to+-- @0..9@:+--+-- >>> map digitToInt ['0'..'9']+-- [0,1,2,3,4,5,6,7,8,9]+--+-- Both upper- and lower-case @\'A\'@ through @\'F\'@ are converted+-- as well, to @10..15@.+--+-- >>> map digitToInt ['a'..'f']+-- [10,11,12,13,14,15]+-- >>> map digitToInt ['A'..'F']+-- [10,11,12,13,14,15]+--+-- Anything else throws an exception:+--+-- >>> digitToInt 'G'+-- *** Exception: Char.digitToInt: not a digit 'G'+-- >>> digitToInt '♥'+-- *** Exception: Char.digitToInt: not a digit '\9829'+--+digitToInt :: Char -> Int+digitToInt c+  | (fromIntegral dec::Word) <= 9 = dec+  | (fromIntegral hexl::Word) <= 5 = hexl + 10+  | (fromIntegral hexu::Word) <= 5 = hexu + 10+  | 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'++-- derived character classifiers++-- | Selects alphabetic Unicode characters (lower-case, upper-case and+-- title-case letters, plus letters of caseless scripts and+-- modifiers letters). This function is equivalent to+-- 'Data.Char.isAlpha'.+--+-- This function returns 'True' if its argument has one of the+-- following 'GeneralCategory's, or 'False' otherwise:+--+-- * 'UppercaseLetter'+-- * 'LowercaseLetter'+-- * 'TitlecaseLetter'+-- * 'ModifierLetter'+-- * 'OtherLetter'+--+-- These classes are defined in the+-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,+-- part of the Unicode standard. The same document defines what is+-- and is not a \"Letter\".+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> isLetter 'a'+-- True+-- >>> isLetter 'A'+-- True+-- >>> isLetter 'λ'+-- True+-- >>> isLetter '0'+-- False+-- >>> isLetter '%'+-- False+-- >>> isLetter '♥'+-- False+-- >>> isLetter '\31'+-- False+--+-- Ensure that 'isLetter' and 'isAlpha' are equivalent.+--+-- >>> let chars = [(chr 0)..]+-- >>> let letters = map isLetter chars+-- >>> let alphas = map isAlpha chars+-- >>> letters == alphas+-- True+--+isLetter :: Char -> Bool+isLetter c = case generalCategory c of+        UppercaseLetter         -> True+        LowercaseLetter         -> True+        TitlecaseLetter         -> True+        ModifierLetter          -> True+        OtherLetter             -> True+        _                       -> False++-- | Selects Unicode mark characters, for example accents and the+-- like, which combine with preceding characters.+--+-- This function returns 'True' if its argument has one of the+-- following 'GeneralCategory's, or 'False' otherwise:+--+-- * 'NonSpacingMark'+-- * 'SpacingCombiningMark'+-- * 'EnclosingMark'+--+-- These classes are defined in the+-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,+-- part of the Unicode standard. The same document defines what is+-- and is not a \"Mark\".+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> isMark 'a'+-- False+-- >>> isMark '0'+-- False+--+-- Combining marks such as accent characters usually need to follow+-- another character before they become printable:+--+-- >>> map isMark "ò"+-- [False,True]+--+-- Puns are not necessarily supported:+--+-- >>> isMark '✓'+-- False+--+isMark :: Char -> Bool+isMark c = case generalCategory c of+        NonSpacingMark          -> True+        SpacingCombiningMark    -> True+        EnclosingMark           -> True+        _                       -> False++-- | Selects Unicode numeric characters, including digits from various+-- scripts, Roman numerals, et cetera.+--+-- This function returns 'True' if its argument has one of the+-- following 'GeneralCategory's, or 'False' otherwise:+--+-- * 'DecimalNumber'+-- * 'LetterNumber'+-- * 'OtherNumber'+--+-- These classes are defined in the+-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,+-- part of the Unicode standard. The same document defines what is+-- and is not a \"Number\".+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> isNumber 'a'+-- False+-- >>> isNumber '%'+-- False+-- >>> isNumber '3'+-- True+--+-- ASCII @\'0\'@ through @\'9\'@ are all numbers:+--+-- >>> and $ map isNumber ['0'..'9']+-- True+--+-- Unicode Roman numerals are \"numbers\" as well:+--+-- >>> isNumber 'Ⅸ'+-- True+--+isNumber :: Char -> Bool+isNumber c = case generalCategory c of+        DecimalNumber           -> True+        LetterNumber            -> True+        OtherNumber             -> True+        _                       -> False++-- | Selects Unicode space and separator characters.+--+-- This function returns 'True' if its argument has one of the+-- following 'GeneralCategory's, or 'False' otherwise:+--+-- * 'Space'+-- * 'LineSeparator'+-- * 'ParagraphSeparator'+--+-- These classes are defined in the+-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,+-- part of the Unicode standard. The same document defines what is+-- and is not a \"Separator\".+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> isSeparator 'a'+-- False+-- >>> isSeparator '6'+-- False+-- >>> isSeparator ' '+-- True+--+-- Warning: newlines and tab characters are not considered+-- separators.+--+-- >>> isSeparator '\n'+-- False+-- >>> isSeparator '\t'+-- False+--+-- But some more exotic characters are (like HTML's @&nbsp;@):+--+-- >>> isSeparator '\160'+-- True+--+isSeparator :: Char -> Bool+isSeparator c = case generalCategory c of+        Space                   -> True+        LineSeparator           -> True+        ParagraphSeparator      -> True+        _                       -> False+
+ src/Data/Coerce.hs view
@@ -0,0 +1,24 @@+-- |+--+-- Module      :  Data.Coerce+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Safe coercions between data types.+--+-- More in-depth information can be found on the+-- <https://gitlab.haskell.org/ghc/ghc/wikis/roles Roles wiki page>+--+-- @since 4.7.0.0++module Data.Coerce+    (-- *  Safe coercions+     coerce,+     Coercible+     ) where++import GHC.Internal.Data.Coerce
+ src/Data/Complex.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Complex+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Complex numbers.+--+-----------------------------------------------------------------------------++module Data.Complex+        (+        -- * Rectangular form+          Complex((:+))++        , realPart+        , imagPart+        -- * Polar form+        , mkPolar+        , cis+        , polar+        , magnitude+        , phase+        -- * Conjugate+        , conjugate++        )  where++import Prelude hiding (Applicative(..))+import GHC.Internal.Base (Applicative (..))+import GHC.Generics (Generic, Generic1)+import GHC.Internal.Float (Floating(..))+import GHC.Internal.Data.Data (Data)+import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf,+                alignment)+import GHC.Internal.Control.Monad.Fix (MonadFix(..))+import Control.Monad.Zip (MonadZip(..))++infix  6  :+++-- $setup+-- >>> import Prelude++-- -----------------------------------------------------------------------------+-- The Complex type++-- | A data type representing complex numbers.+--+-- You can read about complex numbers [on wikipedia](https://en.wikipedia.org/wiki/Complex_number).+--+-- In haskell, complex numbers are represented as @a :+ b@ which can be thought of+-- as representing \(a + bi\). 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'.+-- Apart from the loss of precision due to IEEE754 floating point numbers,+-- it holds that @z == 'abs' z * 'signum' z@.+--+-- Note that `Complex`'s instances inherit the deficiencies from the type+-- parameter's. For example, @Complex Float@'s 'Eq' instance has similar+-- problems to `Float`'s.+--+-- As can be seen in the examples, the 'Foldable'+-- and 'Traversable' instances traverse the real part first.+--+-- ==== __Examples__+--+-- >>> (5.0 :+ 2.5) + 6.5+-- 11.5 :+ 2.5+--+-- >>> abs (1.0 :+ 1.0) - sqrt 2.0+-- 0.0 :+ 0.0+--+-- >>> abs (signum (4.0 :+ 3.0))+-- 1.0 :+ 0.0+--+-- >>> foldr (:) [] (1 :+ 2)+-- [1,2]+--+-- >>> mapM print (1 :+ 2)+-- 1+-- 2+-- () :+ ()+data Complex a+  = !a :+ !a    -- ^ forms a complex number from its real and imaginary+                -- rectangular components.+        deriving ( Eq          -- ^ @since 2.01+                 , Show        -- ^ @since 2.01+                 , Read        -- ^ @since 2.01+                 , Data        -- ^ @since 2.01+                 , Generic     -- ^ @since 4.9.0.0+                 , Generic1    -- ^ @since 4.9.0.0+                 , Functor     -- ^ @since 4.9.0.0+                 , Foldable    -- ^ @since 4.9.0.0+                 , Traversable -- ^ @since 4.9.0.0+                 )+++-- -----------------------------------------------------------------------------+-- Functions over Complex++-- | Extracts the real part of a complex number.+--+-- ==== __Examples__+--+-- >>> realPart (5.0 :+ 3.0)+-- 5.0+--+-- >>> realPart ((5.0 :+ 3.0) * (2.0 :+ 3.0))+-- 1.0+realPart :: Complex a -> a+realPart (x :+ _) =  x++-- | Extracts the imaginary part of a complex number.+--+-- ==== __Examples__+--+-- >>> imagPart (5.0 :+ 3.0)+-- 3.0+--+-- >>> imagPart ((5.0 :+ 3.0) * (2.0 :+ 3.0))+-- 21.0+imagPart :: Complex a -> a+imagPart (_ :+ y) =  y++-- | The 'conjugate' of a complex number.+--+-- prop> conjugate (conjugate x) = x+--+-- ==== __Examples__+--+-- >>> conjugate (3.0 :+ 3.0)+-- 3.0 :+ (-3.0)+--+-- >>> conjugate ((3.0 :+ 3.0) * (2.0 :+ 2.0))+-- 0.0 :+ (-12.0)+{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}+conjugate        :: Num a => Complex a -> Complex a+conjugate (x:+y) =  x :+ (-y)++-- | Form a complex number from 'polar' components of 'magnitude' and 'phase'.+--+-- ==== __Examples__+--+-- >>> mkPolar 1 (pi / 4)+-- 0.7071067811865476 :+ 0.7071067811865475+--+-- >>> mkPolar 1 0+-- 1.0 :+ 0.0+{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-}+mkPolar          :: Floating a => a -> a -> Complex a+mkPolar r theta  =  r * cos theta :+ r * sin theta++-- | @'cis' t@ is a complex value with 'magnitude' @1@+-- and 'phase' @t@ (modulo @2*'pi'@).+--+-- @+-- 'cis' = 'mkPolar' 1+-- @+--+-- ==== __Examples__+--+-- >>> cis 0+-- 1.0 :+ 0.0+--+-- The following examples are not perfectly zero due to [IEEE 754](https://en.wikipedia.org/wiki/IEEE_754)+--+-- >>> cis pi+-- (-1.0) :+ 1.2246467991473532e-16+--+-- >>> cis (4 * pi) - cis (2 * pi)+-- 0.0 :+ (-2.4492935982947064e-16)+{-# SPECIALISE cis :: Double -> Complex Double #-}+cis              :: Floating a => a -> Complex a+cis theta        =  cos theta :+ sin theta++-- | The function 'polar' takes a complex number and+-- returns a ('magnitude', 'phase') pair in canonical form:+-- the 'magnitude' is non-negative, and the 'phase' in the range @(-'pi', 'pi']@;+-- if the 'magnitude' is zero, then so is the 'phase'.+--+-- @'polar' z = ('magnitude' z, 'phase' z)@+--+-- ==== __Examples__+--+-- >>> polar (1.0 :+ 1.0)+-- (1.4142135623730951,0.7853981633974483)+--+-- >>> polar ((-1.0) :+ 0.0)+-- (1.0,3.141592653589793)+--+-- >>> polar (0.0 :+ 0.0)+-- (0.0,0.0)+{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-}+polar            :: (RealFloat a) => Complex a -> (a,a)+polar z          =  (magnitude z, phase z)++-- | The non-negative 'magnitude' of a complex number.+--+-- ==== __Examples__+--+-- >>> magnitude (1.0 :+ 1.0)+-- 1.4142135623730951+--+-- >>> magnitude (1.0 + 0.0)+-- 1.0+--+-- >>> magnitude (0.0 :+ (-5.0))+-- 5.0+{-# SPECIALISE magnitude :: Complex Double -> Double #-}+magnitude :: (RealFloat a) => Complex a -> a+magnitude (x:+y) =  scaleFloat k+                     (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y)))+                    where k  = max (exponent x) (exponent y)+                          mk = - k+                          sqr z = z * z++-- | The 'phase' of a complex number, in the range @(-'pi', 'pi']@.+-- If the 'magnitude' is zero, then so is the 'phase'.+--+-- ==== __Examples__+--+-- >>> phase (0.5 :+ 0.5) / pi+-- 0.25+--+-- >>> phase (0 :+ 4) / pi+-- 0.5+{-# SPECIALISE phase :: Complex Double -> Double #-}+phase :: (RealFloat a) => Complex a -> a+phase (0 :+ 0)   = 0            -- SLPJ July 97 from John Peterson+phase (x:+y)     = atan2 y x+++-- -----------------------------------------------------------------------------+-- Instances of Complex++-- | @since 2.01+instance  (RealFloat a) => Num (Complex a)  where+    {-# SPECIALISE instance Num (Complex Float) #-}+    {-# SPECIALISE instance Num (Complex Double) #-}+    (x:+y) + (x':+y')   =  (x+x') :+ (y+y')+    (x:+y) - (x':+y')   =  (x-x') :+ (y-y')+    (x:+y) * (x':+y')   =  (x*x'-y*y') :+ (x*y'+y*x')+    negate (x:+y)       =  negate x :+ negate y+    abs z               =  magnitude z :+ 0+    signum (0:+0)       =  0+    signum z@(x:+y)     =  x/r :+ y/r  where r = magnitude z+    fromInteger n       =  fromInteger n :+ 0++-- | @since 2.01+instance  (RealFloat a) => Fractional (Complex a)  where+    {-# SPECIALISE instance Fractional (Complex Float) #-}+    {-# SPECIALISE instance Fractional (Complex Double) #-}+    (x:+y) / (x':+y')   =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d+                           where x'' = scaleFloat k x'+                                 y'' = scaleFloat k y'+                                 k   = - max (exponent x') (exponent y')+                                 d   = x'*x'' + y'*y''++    fromRational a      =  fromRational a :+ 0++-- | @since 2.01+instance  (RealFloat a) => Floating (Complex a) where+    {-# SPECIALISE instance Floating (Complex Float) #-}+    {-# SPECIALISE instance Floating (Complex Double) #-}+    pi             =  pi :+ 0+    exp (x:+y)     =  expx * cos y :+ expx * sin y+                      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')+                            v'    = abs y / (u'*2)+                            u'    = sqrt ((magnitude z + abs x) / 2)++    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))+                      where sinx  = sin x+                            cosx  = cos x+                            sinhy = sinh y+                            coshy = cosh y++    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)+                      where siny  = sin y+                            cosy  = cos y+                            sinhx = sinh x+                            coshx = cosh x++    asin z@(x:+y)  =  y':+(-x')+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))+    acos z         =  y'':+(-x'')+                      where (x'':+y'') = log (z + ((-y'):+x'))+                            (x':+y')   = sqrt (1 - z*z)+    atan z@(x:+y)  =  y':+(-x')+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))++    asinh z        =  log (z + sqrt (1+z*z))+    -- Take care to allow (-1)::Complex, fixing #8532+    acosh z        =  log (z + (sqrt $ z+1) * (sqrt $ 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 #-}++-- | @since 4.8.0.0+instance Storable a => Storable (Complex a) where+    sizeOf a       = 2 * sizeOf (realPart a)+    alignment a    = alignment (realPart a)+    peek p           = do+                        q <- return $ castPtr p+                        r <- peek q+                        i <- peekElemOff q 1+                        return (r :+ i)+    poke p (r :+ i)  = do+                        q <-return $  (castPtr p)+                        poke q r+                        pokeElemOff q 1 i++-- | @since 4.9.0.0+instance Applicative Complex where+  pure a = a :+ a+  f :+ g <*> a :+ b = f a :+ g b+  liftA2 f (x :+ y) (a :+ b) = f x a :+ f y b++-- | @since 4.9.0.0+instance Monad Complex where+  a :+ b >>= f = realPart (f a) :+ imagPart (f b)++-- | @since 4.15.0.0+instance MonadZip Complex where+  mzipWith = liftA2++-- | @since 4.15.0.0+instance MonadFix Complex where+  mfix f = (let a :+ _ = f a in a) :+ (let _ :+ a = f a in a)++-- -----------------------------------------------------------------------------+-- Rules on Complex++{-# RULES++"realToFrac/a->Complex Double"+  realToFrac = \x -> realToFrac x :+ (0 :: Double)++"realToFrac/a->Complex Float"+  realToFrac = \x -> realToFrac x :+ (0 :: Float)++  #-}
+ src/Data/Data.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Data.Data+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (local universal quantification)+--+-- This module provides the 'Data' class with its primitives for+-- generic programming, along with instances for many datatypes. It+-- corresponds to a merge between the previous "Data.Generics.Basics"+-- and almost all of "Data.Generics.Instances". The instances that are+-- not present in this module were moved to the+-- @Data.Generics.Instances@ module in the @syb@ package.+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell.  See+-- <https://wiki.haskell.org/Research_papers/Generics#Scrap_your_boilerplate.21>.+--++module Data.Data (++        -- * Module Data.Typeable re-exported for convenience+        module Data.Typeable,++        -- * The Data class for processing constructor applications+        Data(+                gfoldl,+                gunfold,+                toConstr,+                dataTypeOf,+                dataCast1,      -- mediate types and unary type constructors+                dataCast2,      -- mediate types and binary type constructors+                -- Generic maps defined in terms of gfoldl+                gmapT,+                gmapQ,+                gmapQl,+                gmapQr,+                gmapQi,+                gmapM,+                gmapMp,+                gmapMo+            ),++        -- * Datatype representations+        DataType,       -- abstract+        -- ** Constructors+        mkDataType,+        mkIntType,+        mkFloatType,+        mkCharType,+        mkNoRepType,+        -- ** Observers+        dataTypeName,+        DataRep(..),+        dataTypeRep,+        -- ** Convenience functions+        repConstr,+        isAlgType,+        dataTypeConstrs,+        indexConstr,+        maxConstrIndex,+        isNorepType,++        -- * Data constructor representations+        Constr,         -- abstract+        ConIndex,       -- alias for Int, start at 1+        Fixity(..),+        -- ** Constructors+        mkConstr,+        mkConstrTag,+        mkIntegralConstr,+        mkRealConstr,+        mkCharConstr,+        -- ** Observers+        constrType,+        ConstrRep(..),+        constrRep,+        constrFields,+        constrFixity,+        -- ** Convenience function: algebraic data types+        constrIndex,+        -- ** From strings to constructors and vice versa: all data types+        showConstr,+        readConstr,++        -- * Convenience functions: take type constructors apart+        tyconUQname,+        tyconModule,++        -- * Generic operations defined in terms of 'gunfold'+        fromConstr,+        fromConstrB,+        fromConstrM++  ) where++import GHC.Internal.Data.Data+import Data.Typeable
+ src/Data/Dynamic.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Dynamic+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Dynamic interface provides basic support for dynamic types.+--+-- Operations for injecting values of arbitrary type into+-- a dynamically typed value, Dynamic, are provided, together+-- with operations for converting dynamic values into a concrete+-- (monomorphic) type.+--++module Data.Dynamic+    (-- *  The @Dynamic@ type+     Dynamic(..),+     -- *  Converting to and from @Dynamic@+     toDyn,+     fromDyn,+     fromDynamic,+     -- *  Applying functions of dynamic type+     dynApply,+     dynApp,+     dynTypeRep,+     -- *  Convenience re-exports+     Typeable+     ) where++import GHC.Internal.Data.Dynamic
+ src/Data/Either.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Either+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Either type, and associated operations.+--++module Data.Either+    (Either(..),+     either,+     lefts,+     rights,+     isLeft,+     isRight,+     fromLeft,+     fromRight,+     partitionEithers+     ) where++import GHC.Internal.Data.Either
+ src/Data/Enum.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Enum+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (GHC extensions)+--+-- The 'Enum' class.+--+-- @since 4.20.0.0+--+-----------------------------------------------------------------------------++module Data.Enum+    ( Enum(..)+    , {-# DEPRECATED "Bounded should be imported from Data.Bounded" #-}+      Bounded(..)+    , enumerate+    ) where++import GHC.Internal.Enum++-- | Returns a list of all values of an enum type+--+-- 'enumerate' is often used to list all values of a custom enum data structure, such as a custom Color enum below:+--+-- @+-- data Color = Yellow | Red | Blue+--     deriving (Enum, Bounded, Show)+--+-- allColors :: [Color]+-- allColors = enumerate+-- -- Result: [Yellow, Red, Blue]+-- @+--+-- Note that you need to derive the 'Bounded' type class as well, only 'Enum' is not enough.+-- 'Enum' allows for sequential enumeration, while 'Bounded' provides the 'minBound' and 'maxBound' values.+--+-- 'enumerate' is commonly used together with the TypeApplications syntax. Here is an example of using 'enumerate' to retrieve all values of the 'Ordering' type:+--+-- >> enumerate @Ordering+-- [LT, EQ, GT]+--+-- The '@' symbol here is provided by the TypeApplications language extension.+--+-- @since base-4.22.0.0+enumerate :: (Enum a, Bounded a) => [a]+enumerate = [minBound .. maxBound]
+ src/Data/Eq.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Eq+-- Copyright   :  (c) The University of Glasgow 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Equality+--++module Data.Eq+    (Eq(..)+     ) where++import GHC.Internal.Data.Eq
+ src/Data/Fixed.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Fixed+-- Copyright   :  (c) Ashley Yakeley 2005, 2006, 2009+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Ashley Yakeley <ashley@semantic.org>+-- Stability   :  stable+-- Portability :  portable+--+-- This module defines a 'Fixed' type for working with fixed-point arithmetic.+-- Fixed-point arithmetic represents fractional numbers with a fixed number of+-- digits for their fractional part. This is different to the behaviour of the floating-point+-- number types 'Float' and 'Double', because the number of digits of the+-- fractional part of 'Float' and 'Double' numbers depends on the size of the number.+-- Fixed point arithmetic is frequently used in financial mathematics, where they+-- are used for representing decimal currencies.+--+-- The type 'Fixed' is used for fixed-point fractional numbers, which are internally+-- represented as an 'Integer'. The type 'Fixed' takes one parameter, which should implement+-- the typeclass 'HasResolution', to specify the number of digits of the fractional part.+-- This module provides instances of the `HasResolution` typeclass for arbitrary typelevel+-- natural numbers, and for some canonical important fixed-point representations.+--+-- This module also contains generalisations of 'div', 'mod', and 'divMod' to+-- work with any 'Real' instance.+--+-- Automatic conversion between different 'Fixed' can be performed through+-- 'realToFrac', bear in mind that converting to a fixed with a smaller+-- resolution will truncate the number, losing information.+--+-- >>> realToFrac (0.123456 :: Pico) :: Milli+-- 0.123+--+-----------------------------------------------------------------------------++module Data.Fixed+(   -- * The Fixed Type+    Fixed(..), HasResolution(..),+    showFixed,+    -- * Resolution \/ Scaling Factors+    -- | The resolution or scaling factor determines the number of digits in the fractional part.+    --+    -- +------------+----------------------+--------------------------+--------------------------++    -- | Resolution | Scaling Factor       | Synonym for \"Fixed EX\" | show (12345 :: Fixed EX) |+    -- +============+======================+==========================+==========================++    -- | E0         | 1\/1                 | Uni                      | 12345.0                  |+    -- +------------+----------------------+--------------------------+--------------------------++    -- | E1         | 1\/10                | Deci                     | 1234.5                   |+    -- +------------+----------------------+--------------------------+--------------------------++    -- | E2         | 1\/100               | Centi                    | 123.45                   |+    -- +------------+----------------------+--------------------------+--------------------------++    -- | E3         | 1\/1 000             | Milli                    | 12.345                   |+    -- +------------+----------------------+--------------------------+--------------------------++    -- | E6         | 1\/1 000 000         | Micro                    | 0.012345                 |+    -- +------------+----------------------+--------------------------+--------------------------++    -- | E9         | 1\/1 000 000 000     | Nano                     | 0.000012345              |+    -- +------------+----------------------+--------------------------+--------------------------++    -- | E12        | 1\/1 000 000 000 000 | Pico                     | 0.000000012345           |+    -- +------------+----------------------+--------------------------+--------------------------++    --++    -- ** 1\/1+    E0,Uni,+    -- ** 1\/10+    E1,Deci,+    -- ** 1\/100+    E2,Centi,+    -- ** 1\/1 000+    E3,Milli,+    -- ** 1\/1 000 000+    E6,Micro,+    -- ** 1\/1 000 000 000+    E9,Nano,+    -- ** 1\/1 000 000 000 000+    E12,Pico,+    -- * Generalized Functions on Real's+    div',+    mod',+    divMod'+) where++import GHC.Internal.Data.Data+import GHC.Internal.TypeLits (KnownNat, natVal)+import GHC.Internal.Read+import GHC.Internal.Text.ParserCombinators.ReadPrec+import GHC.Internal.Text.Read.Lex+import qualified GHC.Internal.TH.Syntax as TH+import qualified GHC.Internal.TH.Lift as TH+import Data.Typeable+import Prelude++-- $setup+-- >>> import Prelude++default () -- avoid any defaulting shenanigans++-- | Generalisation of 'div' to any instance of 'Real'+div' :: (Real a,Integral b) => a -> a -> b+div' n d = floor ((toRational n) / (toRational d))++-- | Generalisation of 'divMod' to any instance of 'Real'+divMod' :: (Real a,Integral b) => a -> a -> (b,a)+divMod' n d = (f,n - (fromIntegral f) * d) where+    f = div' n d++-- | Generalisation of 'mod' to any instance of 'Real'+mod' :: (Real a) => a -> a -> a+mod' n d = n - (fromInteger f) * d where+    f = div' n d++-- | The type of fixed-point fractional numbers.+--   The type parameter specifies the number of digits of the fractional part and should be an instance of the 'HasResolution' typeclass.+--+-- === __Examples__+--+-- @+--  MkFixed 12345 :: Fixed E3+-- @+newtype Fixed (a :: k) = MkFixed Integer+        deriving ( Eq  -- ^ @since 2.01+                 , Ord -- ^ @since 2.01+                 )++-- We do this because the automatically derived Data instance requires (Data a) context.+-- Our manual instance has the more general (Typeable a) context.+tyFixed :: DataType+tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]++conMkFixed :: Constr+conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix++-- | @since 4.1.0.0+instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where+    gfoldl k z (MkFixed a) = k (z MkFixed) a+    gunfold k z _ = k (z MkFixed)+    dataTypeOf _ = tyFixed+    toConstr _ = conMkFixed++-- |+-- @since template-haskell-2.19.0.0+-- @since base-4.21.0.0+instance TH.Lift (Fixed a) where+  liftTyped x = TH.unsafeCodeCoerce (TH.lift x)+  lift (MkFixed x) = [| MkFixed x |]++-- | Types which can be used as a resolution argument to the 'Fixed' type constructor must implement the 'HasResolution'  typeclass.+class HasResolution (a :: k) where+    -- | Provide the resolution for a fixed-point fractional number.+    resolution :: p a -> Integer++-- | For example, @Fixed 1000@ will give you a 'Fixed' with a resolution of 1000.+instance KnownNat n => HasResolution n where+    resolution _ = natVal (Proxy :: Proxy n)++withType :: (Proxy a -> f a) -> f a+withType foo = foo Proxy++withResolution :: (HasResolution a) => (Integer -> f a) -> f a+withResolution foo = withType (foo . resolution)++-- | @since 2.01+--+-- Recall that, for numeric types, 'succ' and 'pred' typically add and subtract+-- @1@, respectively. This is not true in the case of 'Fixed', whose successor+-- and predecessor functions intuitively return the "next" and "previous" values+-- in the enumeration. The results of these functions thus depend on the+-- resolution of the 'Fixed' value. For example, when enumerating values of+-- resolution @10^-3@ of @type Milli = Fixed E3@,+--+-- >>> succ (0.000 :: Milli)+-- 0.001+--+-- and likewise+--+-- >>> pred (0.000 :: Milli)+-- -0.001+--+-- In other words, 'succ' and 'pred' increment and decrement a fixed-precision+-- value by the least amount such that the value's resolution is unchanged.+-- For example, @10^-12@ is the smallest (positive) amount that can be added to+-- a value of @type Pico = Fixed E12@ without changing its resolution, and so+--+-- >>> succ (0.000000000000 :: Pico)+-- 0.000000000001+--+-- and similarly+--+-- >>> pred (0.000000000000 :: Pico)+-- -0.000000000001+--+--+-- This is worth bearing in mind when defining 'Fixed' arithmetic sequences. In+-- particular, you may be forgiven for thinking the sequence+--+-- @+--   [1..10] :: [Pico]+-- @+--+--+-- evaluates to @[1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Pico]@.+--+-- However, this is not true. On the contrary, similarly to the above+-- implementations of 'succ' and 'pred', @enumFromTo :: Pico -> Pico -> [Pico]@+-- has a "step size" of @10^-12@. Hence, the list @[1..10] :: [Pico]@ has+-- the form+--+-- @+--   [1.000000000000, 1.00000000001, 1.00000000002, ..., 10.000000000000]+-- @+--+--+-- and contains @9 * 10^12 + 1@ values.+instance Enum (Fixed a) where+    succ (MkFixed a) = MkFixed (succ a)+    pred (MkFixed a) = MkFixed (pred a)+    toEnum = MkFixed . toEnum+    fromEnum (MkFixed a) = fromEnum a+    enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)+    enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)+    enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)+    enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)++-- | @since 2.01+--+-- Multiplication is not associative or distributive:+--+-- >>> (0.2 * 0.6 :: Deci) * 0.9 == 0.2 * (0.6 * 0.9)+-- False+--+-- >>> (0.1 + 0.1 :: Deci) * 0.5 == 0.1 * 0.5 + 0.1 * 0.5+-- False+instance (HasResolution a) => Num (Fixed a) where+    (MkFixed a) + (MkFixed b) = MkFixed (a + b)+    (MkFixed a) - (MkFixed b) = MkFixed (a - b)+    fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))+    negate (MkFixed a) = MkFixed (negate a)+    abs (MkFixed a) = MkFixed (abs a)+    signum (MkFixed a) = fromInteger (signum a)+    fromInteger i = withResolution (\res -> MkFixed (i * res))++-- | @since 2.01+instance (HasResolution a) => Real (Fixed a) where+    toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))++-- | @since 2.01+instance (HasResolution a) => Fractional (Fixed a) where+    fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)+    recip fa@(MkFixed a) = MkFixed (div (res * res) a) where+        res = resolution fa+    fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))++-- | @since 2.01+instance (HasResolution a) => RealFrac (Fixed a) where+    properFraction a = (i,a - (fromIntegral i)) where+        i = truncate a+    truncate f = truncate (toRational f)+    round f = round (toRational f)+    ceiling f = ceiling (toRational f)+    floor f = floor (toRational f)++chopZeros :: Integer -> String+chopZeros 0 = ""+chopZeros a | mod a 10 == 0 = chopZeros (div a 10)+chopZeros a = show a++-- only works for positive a+showIntegerZeros :: Bool -> Int -> Integer -> String+showIntegerZeros True _ 0 = ""+showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where+    s = show a+    s' = if chopTrailingZeros then chopZeros a else s++withDot :: String -> String+withDot "" = ""+withDot s = '.':s++-- | First arg is whether to chop off trailing zeros+--+-- === __Examples__+--+-- >>> showFixed True  (MkFixed 10000 :: Fixed E3)+-- "10"+--+-- >>> showFixed False (MkFixed 10000 :: Fixed E3)+-- "10.000"+--+showFixed :: (HasResolution a) => Bool -> Fixed a -> String+showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))+showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where+    res = resolution fa+    (i,d) = divMod a res+    -- enough digits to be unambiguous+    digits = ceiling (logBase 10 (fromInteger res) :: Double)+    maxnum = 10 ^ digits+    -- read floors, so show must ceil for `read . show = id` to hold. See #9240+    fracNum = divCeil (d * maxnum) res+    divCeil x y = (x + y - 1) `div` y++-- | @since 2.01+instance (HasResolution a) => Show (Fixed a) where+    showsPrec p n = showParen (p > 6 && n < 0) $ showString $ showFixed False n++-- | @since 4.3.0.0+instance (HasResolution a) => Read (Fixed a) where+    readPrec     = readNumber convertFixed+    readListPrec = readListPrecDefault+    readList     = readListDefault++convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)+convertFixed (Number n)+ | Just (i, f) <- numberToFixed e n =+    return (fromInteger i + (fromInteger f / (10 ^ e)))+    where r = resolution (Proxy :: Proxy a)+          -- round 'e' up to help make the 'read . show == id' property+          -- possible also for cases where 'resolution' is not a+          -- power-of-10, such as e.g. when 'resolution = 128'+          e = ceiling (logBase 10 (fromInteger r) :: Double)+convertFixed _ = pfail++-- | Resolution of 1, this works the same as Integer.+data E0++-- | @since 4.1.0.0+instance HasResolution E0 where+    resolution _ = 1++-- | Resolution of 1, this works the same as Integer.+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E0)+-- "12345.0"+--+-- >>> show (MkFixed 12345 :: Uni)+-- "12345.0"+--+type Uni = Fixed E0++-- | Resolution of 10^-1 = .1+data E1++-- | @since 4.1.0.0+instance HasResolution E1 where+    resolution _ = 10++-- | Resolution of 10^-1 = .1+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E1)+-- "1234.5"+--+-- >>> show (MkFixed 12345 :: Deci)+-- "1234.5"+--+type Deci = Fixed E1++-- | Resolution of 10^-2 = .01, useful for many monetary currencies+data E2++-- | @since 4.1.0.0+instance HasResolution E2 where+    resolution _ = 100++-- | Resolution of 10^-2 = .01, useful for many monetary currencies+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E2)+-- "123.45"+--+-- >>> show (MkFixed 12345 :: Centi)+-- "123.45"+--+type Centi = Fixed E2++-- | Resolution of 10^-3 = .001+data E3++-- | @since 4.1.0.0+instance HasResolution E3 where+    resolution _ = 1000++-- | Resolution of 10^-3 = .001+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E3)+-- "12.345"+--+-- >>> show (MkFixed 12345 :: Milli)+-- "12.345"+--+type Milli = Fixed E3++-- | Resolution of 10^-6 = .000001+data E6++-- | @since 2.01+instance HasResolution E6 where+    resolution _ = 1000000++-- | Resolution of 10^-6 = .000001+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E6)+-- "0.012345"+--+-- >>> show (MkFixed 12345 :: Micro)+-- "0.012345"+--+type Micro = Fixed E6++-- | Resolution of 10^-9 = .000000001+data E9++-- | @since 4.1.0.0+instance HasResolution E9 where+    resolution _ = 1000000000++-- | Resolution of 10^-9 = .000000001+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E9)+-- "0.000012345"+--+-- >>> show (MkFixed 12345 :: Nano)+-- "0.000012345"+--+type Nano = Fixed E9++-- | Resolution of 10^-12 = .000000000001+data E12++-- | @since 2.01+instance HasResolution E12 where+    resolution _ = 1000000000000++-- | Resolution of 10^-12 = .000000000001+--+-- === __Examples__+--+-- >>> show (MkFixed 12345 :: Fixed E12)+-- "0.000000012345"+--+-- >>> show (MkFixed 12345 :: Pico)+-- "0.000000012345"+--+type Pico = Fixed E12
+ src/Data/Foldable.hs view
@@ -0,0 +1,1119 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Data.Foldable+-- Copyright   :  Ross Paterson 2005+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Class of data structures that can be folded to a summary value.+--++module Data.Foldable (+    Foldable(..),+    -- * Special biased folds+    foldrM,+    foldlM,+    -- * Folding actions+    -- ** Applicative actions+    traverse_,+    for_,+    sequenceA_,+    asum,+    -- ** Monadic actions+    mapM_,+    forM_,+    sequence_,+    msum,+    -- * Specialized folds+    concat,+    concatMap,+    and,+    or,+    any,+    all,+    maximumBy,+    minimumBy,+    -- * Searches+    notElem,+    find++    -- * Overview+    -- $overview++    -- ** Expectation of efficient left-to-right iteration+    -- $chirality++    -- ** Recursive and corecursive reduction+    -- $reduction++    -- *** Strict recursive folds+    -- $strict++    -- **** List of strict functions+    -- $strictlist++    -- *** Lazy corecursive folds+    -- $lazy++    -- **** List of lazy functions+    -- $lazylist++    -- *** Short-circuit folds+    -- $shortcircuit++    -- **** List of short-circuit functions+    -- $shortlist++    -- *** Hybrid folds+    -- $hybrid++    -- ** Generative Recursion+    -- $generative++    -- ** Avoiding multi-pass folds+    -- $multipass++    -- * Defining instances+    -- $instances++    -- *** Being strict by being lazy+    -- $strictlazy++    -- * Laws+    -- $laws++    -- * Notes+    -- $notes++    -- ** Generally linear-time `elem`+    -- $linear++    -- * See also+    -- $also+    ) where++import GHC.Internal.Data.Foldable++-- $setup+-- >>> import Prelude+-- >>> import qualified Data.List as List++-- $overview+--+-- #overview#+-- The Foldable class generalises some common "Data.List" functions to+-- structures that can be reduced to a summary value one element at a time.+--+-- == Left and right folds+--+-- #leftright#+-- The contribution of each element to the final result is combined with an+-- accumulator via a suitable /operator/.  The operator may be explicitly+-- provided by the caller as with `foldr` or may be implicit as in `length`.+-- In the case of `foldMap`, the caller provides a function mapping each+-- element into a suitable 'Monoid', which makes it possible to merge the+-- per-element contributions via that monoid's `mappend` function.+--+-- A key distinction is between left-associative and right-associative+-- folds:+--+-- * In left-associative folds the accumulator is a partial fold over the+--   elements that __precede__ the current element, and is passed to the+--   operator as its first (left) argument.  The outermost application of the+--   operator merges the contribution of the last element of the structure with+--   the contributions of all its predecessors.+--+-- * In right-associative folds the accumulator is a partial fold over the+--   elements that __follow__ the current element, and is passed to the+--   operator as its second (right) argument.  The outermost application of+--   the operator merges the contribution of the first element of the structure+--   with the contributions of all its successors.+--+-- These two types of folds are typified by the left-associative strict+-- 'foldl'' and the right-associative lazy `foldr`.+--+-- @+-- 'foldl'' :: Foldable t => (b -> a -> b) -> b -> t a -> b+-- `foldr`  :: Foldable t => (a -> b -> b) -> b -> t a -> b+-- @+--+-- Example usage:+--+-- >>> foldl' (+) 0 [1..100]+-- 5050+-- >>> foldr (&&) True (List.repeat False)+-- False+--+-- The first argument of both is an explicit /operator/ that merges the+-- contribution of an element of the structure with a partial fold over,+-- respectively, either the preceding or following elements of the structure.+--+-- The second argument of both is an initial accumulator value @z@ of type+-- @b@.  This is the result of the fold when the structure is empty.+-- When the structure is non-empty, this is the accumulator value merged with+-- the first element in left-associative folds, or with the last element in+-- right-associative folds.+--+-- The third and final argument is a @Foldable@ structure containing elements+-- @(a, b, c, &#x2026;)@.+--+-- * __'foldl''__ takes an operator argument of the form:+--+--     @+--     f :: b -- accumulated fold of the initial elements+--       -> a -- current element+--       -> b -- updated fold, inclusive of current element+--     @+--+--     If the structure's last element is @y@, the result of the fold is:+--+--     @+--     g y . &#x2026; . g c . g b . g a $ z+--       where g element !acc = f acc element+--     @+--+--     Since 'foldl'' is strict in the accumulator, this is always+--     a [strict](#strict) reduction with no opportunity for early return or+--     intermediate results.  The structure must be finite, since no result is+--     returned until the last element is processed.  The advantage of+--     strictness is space efficiency: the final result can be computed without+--     storing a potentially deep stack of lazy intermediate results.+--+-- * __`foldr`__ takes an operator argument of the form:+--+--     @+--     f :: a -- current element+--       -> b -- accumulated fold of the remaining elements+--       -> b -- updated fold, inclusive of current element+--     @+--+--     the result of the fold is:+--+--     @f a . f b . f c . &#x2026; $ z@+--+--     If each call of @f@ on the current element @e@, (referenced as @(f e)@+--     below) returns a structure in which its second argument is captured in a+--     lazily-evaluated component, then the fold of the remaining elements is+--     available to the caller of `foldr` as a pending computation (thunk) that+--     is computed only when that component is evaluated.+--+--     Alternatively, if any of the @(f e)@ ignore their second argument, the+--     fold stops there, with the remaining elements unused.  As a result,+--     `foldr` is well suited to define both [corecursive](#corec)+--     and [short-circuit](#short) reductions.+--+--     When the operator is always strict in its second argument, 'foldl'' is+--     generally a better choice than `foldr`.  When `foldr` is called with a+--     strict operator, evaluation cannot begin until the last element is+--     reached, by which point a deep stack of pending function applications+--     may have been built up in memory.+--++-- $chirality+--+-- #chirality#+-- Foldable structures are generally expected to be efficiently iterable from+-- left to right. Right-to-left iteration may be substantially more costly, or+-- even impossible (as with, for example, infinite lists).  The text in the+-- sections that follow that suggests performance differences between+-- left-associative and right-associative folds assumes /left-handed/+-- structures in which left-to-right iteration is cheaper than right-to-left+-- iteration.+--+-- In finite structures for which right-to-left sequencing no less efficient+-- than left-to-right sequencing, there is no inherent performance distinction+-- between left-associative and right-associative folds.  If the structure's+-- @Foldable@ instance takes advantage of this symmetry to also make strict+-- right folds space-efficient and lazy left folds corecursive, one need only+-- take care to choose either a strict or lazy method for the task at hand.+--+-- Foldable instances for symmetric structures should strive to provide equally+-- performant left-associative and right-associative interfaces. The main+-- limitations are:+--+-- * The lazy 'fold', 'foldMap' and 'toList' methods have no right-associative+--   counterparts.+-- * The strict 'foldMap'' method has no left-associative counterpart.+--+-- Thus, for some foldable structures 'foldr'' is just as efficient as 'foldl''+-- for strict reduction, and 'foldl' may be just as appropriate for corecursive+-- folds as 'foldr'.+--+-- Finally, in some less common structures (e.g. /snoc/ lists) right to left+-- iterations are cheaper than left to right.  Such structures are poor+-- candidates for a @Foldable@ instance, and are perhaps best handled via their+-- type-specific interfaces.  If nevertheless a @Foldable@ instance is+-- provided, the material in the sections that follow applies to these also, by+-- replacing each method with one with the opposite associativity (when+-- available) and switching the order of arguments in the fold's /operator/.+--+-- You may need to pay careful attention to strictness of the fold's /operator/+-- when its strictness is different between its first and second argument.+-- For example, while @('+')@ is expected to be commutative and strict in both+-- arguments, the list concatenation operator @('++')@ is not commutative and+-- is only strict in the initial constructor of its first argument.  The fold:+--+-- > myconcat xs = foldr (\a b -> a ++ b) [] xs+--+-- is substantially cheaper (linear in the length of the consumed portion of+-- the final list, thus e.g. constant time/space for just the first element)+-- than:+--+-- > revconcat xs = foldr (\a b -> b ++ a) [] xs+--+-- In which the total cost scales up with both the number of lists combined and+-- the number of elements ultimately consumed.  A more efficient way to combine+-- lists in reverse order, is to use:+--+-- > revconcat = foldr (++) [] . reverse++--------------++-- $reduction+--+-- As observed in the [above description](#leftright) of left and right folds,+-- there are three general ways in which a structure can be reduced to a+-- summary value:+--+-- * __Recursive__ reduction, which is strict in all the elements of the+--   structure.  This produces a single final result only after processing the+--   entire input structure, and so the input must be finite.+--+-- * __Corecursion__, which yields intermediate results as it encounters+--   additional input elements.  Lazy processing of the remaining elements+--   makes the intermediate results available even before the rest of the+--   input is processed.  The input may be unbounded, and the caller can+--   stop processing intermediate results early.+--+-- * __Short-circuit__ reduction, which examines some initial sequence of the+--   input elements, but stops once a termination condition is met, returning a+--   final result based only on the elements considered up to that point.  The+--   remaining elements are not considered.  The input should generally be+--   finite, because the termination condition might otherwise never be met.+--+-- Whether a fold is recursive, corecursive or short-circuiting can depend on+-- both the method chosen to perform the fold and on the operator passed to+-- that method (which may be implicit, as with the `mappend` method of a monoid+-- instance).+--+-- There are also hybrid cases, where the method and/or operator are not well+-- suited to the task at hand, resulting in a fold that fails to yield+-- incremental results until the entire input is processed, or fails to+-- strictly evaluate results as it goes, deferring all the work to the+-- evaluation of a large final thunk.  Such cases should be avoided, either by+-- selecting a more appropriate @Foldable@ method, or by tailoring the operator+-- to the chosen method.+--+-- The distinction between these types of folds is critical, both in deciding+-- which @Foldable@ method to use to perform the reduction efficiently, and in+-- writing @Foldable@ instances for new structures.  Below is a more detailed+-- overview of each type.++--------------++-- $strict+-- #strict#+--+-- Common examples of strict recursive reduction are the various /aggregate/+-- functions, like 'sum', 'product', 'length', as well as more complex+-- summaries such as frequency counts.  These functions return only a single+-- value after processing the entire input structure.  In such cases, lazy+-- processing of the tail of the input structure is generally not only+-- unnecessary, but also inefficient.  Thus, these and similar folds should be+-- implemented in terms of strict left-associative @Foldable@ methods (typically+-- 'foldl'') to perform an efficient reduction in constant space.+--+-- Conversely, an implementation of @Foldable@ for a new structure should+-- ensure that 'foldl'' actually performs a strict left-associative reduction.+--+-- The 'foldMap'' method is a special case of 'foldl'', in which the initial+-- accumulator is `mempty` and the operator is @mappend . f@, where @f@ maps+-- each input element into the 'Monoid' in question.  Therefore, 'foldMap'' is+-- an appropriate choice under essentially the same conditions as 'foldl'', and+-- its implementation for a given @Foldable@ structure should also be a strict+-- left-associative reduction.+--+-- While the examples below are not necessarily the most optimal definitions of+-- the intended functions, they are all cases in which 'foldMap'' is far more+-- appropriate (as well as more efficient) than the lazy `foldMap`.+--+-- > length  = getSum     . foldMap' (const (Sum 1))+-- > sum     = getSum     . foldMap' Sum+-- > product = getProduct . foldMap' Product+--+-- [ The actual default definitions employ coercions to optimise out+--   'getSum' and 'getProduct'. ]++--------------++-- $strictlist+--+-- The full list of strict recursive functions in this module is:+--+-- * Provided the operator is strict in its left argument:+--+--     @'foldl'' :: Foldable t => (b -> a -> b) -> b -> t a -> b@+--+-- * Provided `mappend` is strict in its left argument:+--+--     @'foldMap'' :: (Foldable t, Monoid m) => (a -> m) -> t a -> m@+--+-- * Provided the instance is correctly defined:+--+--     @+--     `length`    :: Foldable t => t a -> Int+--     `sum`       :: (Foldable t, Num a) => t a -> a+--     `product`   :: (Foldable t, Num a) => t a -> a+--     `maximum`   :: (Foldable t, Ord a) => t a -> a+--     `minimum`   :: (Foldable t, Ord a) => t a -> a+--     `maximumBy` :: Foldable t => (a -> a -> Ordering) -> t a -> a+--     `minimumBy` :: Foldable t => (a -> a -> Ordering) -> t a -> a+--     @++--------------++-- $lazy+--+-- #corec#+-- Common examples of lazy corecursive reduction are functions that map and+-- flatten a structure to a lazy stream of result values, i.e.  an iterator+-- over the transformed input elements.  In such cases, it is important to+-- choose a @Foldable@ method that is lazy in the tail of the structure, such+-- as `foldr` (or `foldMap`, if the result @Monoid@ has a lazy `mappend` as+-- with e.g. ByteString Builders).+--+-- Conversely, an implementation of `foldr` for a structure that can+-- accommodate a large (and possibly unbounded) number of elements is expected+-- to be lazy in the tail of the input, allowing operators that are lazy in the+-- accumulator to yield intermediate results incrementally.  Such folds are+-- right-associative, with the tail of the stream returned as a lazily+-- evaluated component of the result (an element of a tuple or some other+-- non-strict constructor, e.g. the @(:)@ constructor for lists).+--+-- The @toList@ function below lazily transforms a @Foldable@ structure to a+-- List.  Note that this transformation may be lossy, e.g.  for a keyed+-- container (@Map@, @HashMap@, &#x2026;) the output stream holds only the+-- values, not the keys.  Lossless transformations to\/from lists of @(key,+-- value)@ pairs are typically available in the modules for the specific+-- container types.+--+-- > toList = foldr (:) []+--+-- A more complex example is concatenation of a list of lists expressed as a+-- nested right fold (bypassing @('++')@).  We can check that the definition is+-- indeed lazy by folding an infinite list of lists, and taking an initial+-- segment.+--+-- >>> myconcat = foldr (\x z -> foldr (:) z x) []+-- >>> List.take 15 $ myconcat $ List.map (\i -> [0..i]) [0..]+-- [0,0,1,0,1,2,0,1,2,3,0,1,2,3,4]+--+-- Of course in this case another way to achieve the same result is via a+-- list comprehension:+--+-- > myconcat xss = [x | xs <- xss, x <- xs]++--------------++-- $lazylist+--+-- The full list of lazy corecursive functions in this module is:+--+-- * Provided the reduction function is lazy in its second argument,+--   (otherwise best to use a strict recursive reduction):+--+--     @+--     `foldr`  :: Foldable t => (a -> b -> b) -> b -> t a -> b+--     `foldr1` :: Foldable t => (a -> a -> a) -> t a -> a+--     @+--+-- * Provided the 'Monoid' `mappend` is lazy in its second argument+--   (otherwise best to use a strict recursive reduction):+--+--     @+--     `fold`    :: Foldable t => Monoid m => t m -> m+--     `foldMap` :: Foldable t => Monoid m => (a -> m) -> t a -> m+--     @+--+-- * Provided the instance is correctly defined:+--+--     @+--     `toList`    :: Foldable t => t a -> [a]+--     `concat`    :: Foldable t => t [a] -> [a]+--     `concatMap` :: Foldable t => (a -> [b]) -> t a -> [b]+--     @++--------------++-- $shortcircuit+--+-- #short#+-- Examples of short-circuit reduction include various boolean predicates that+-- test whether some or all the elements of a structure satisfy a given+-- condition.  Because these don't necessarily consume the entire list, they+-- typically employ `foldr` with an operator that is conditionally strict in+-- its second argument.  Once the termination condition is met the second+-- argument (tail of the input structure) is ignored.  No result is returned+-- until that happens.+--+-- The key distinguishing feature of these folds is /conditional/ strictness+-- in the second argument, it is sometimes evaluated and sometimes not.+--+-- The simplest (degenerate case) of these is 'null', which determines whether+-- a structure is empty or not.  This only needs to look at the first element,+-- and only to the extent of whether it exists or not, and not its value.  In+-- this case termination is guaranteed, and infinite input structures are fine.+-- Its default definition is of course in terms of the lazy 'foldr':+--+-- > null = foldr (\_ _ -> False) True+--+-- A more general example is `any`, which applies a predicate to each input+-- element in turn until it finds the first one for which the predicate is+-- true, at which point it returns success.  If, in an infinite input stream+-- the predicate is false for all the elements, `any` will not terminate,+-- but since it runs in constant space, it typically won't run out of memory,+-- it'll just loop forever.++--------------++-- $shortlist+--+-- The full list of short-circuit folds in this module is:+--+-- * Boolean predicate folds.+--   These functions examine elements strictly until a condition is met,+--   but then return a result ignoring the rest (lazy in the tail).  These+--   may loop forever given an unbounded input where no elements satisfy the+--   termination condition.+--+--     @+--     `null`    :: Foldable t => t a -> Bool+--     `elem`    :: Foldable t => Eq a => a -> t a -> Bool+--     `notElem` :: (Foldable t, Eq a) => a -> t a -> Bool+--     `and`     :: Foldable t => t Bool -> Bool+--     `or`      :: Foldable t => t Bool -> Bool+--     `find`    :: Foldable t => (a -> Bool) -> t a -> Maybe a+--     `any`     :: Foldable t => (a -> Bool) -> t a -> Bool+--     `all`     :: Foldable t => (a -> Bool) -> t a -> Bool+--     @+--+-- * Many instances of @('<|>')@ (e.g. the 'Maybe' instance) are conditionally+--   lazy, and use or don't use their second argument depending on the value+--   of the first.  These are used with the folds below, which terminate as+--   early as possible, but otherwise generally keep going.  Some instances+--   (e.g. for List) are always strict, but the result is lazy in the tail+--   of the output, so that `asum` for a list of lists is in fact corecursive.+--   These folds are defined in terms of `foldr`.+--+--     @+--     `asum` :: (Foldable t, Alternative f) => t (f a) -> f a+--     `msum` :: (Foldable t, MonadPlus m) => t (m a) -> m a+--     @+--+-- * Likewise, the @('*>')@ operator in some `Applicative` functors, and @('>>')@+--   in some monads are conditionally lazy and can /short-circuit/ a chain of+--   computations.  The below folds will terminate as early as possible, but+--   even infinite loops can be productive here, when evaluated solely for+--   their stream of IO side-effects.  See "Data.Traversable#effectful"+--   for discussion of related functions.+--+--     @+--     `traverse_`  :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()+--     `for_`       :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()+--     `sequenceA_` :: (Foldable t, Applicative f) => t (f a) -> f ()+--     `mapM_`      :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()+--     `forM_`      :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()+--     `sequence_`  :: (Foldable t, Monad m) => t (m a) -> m ()+--     @+--+-- * Finally, there's one more special case, `foldlM`:+--+--     @`foldlM` :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b@+--+--     The sequencing of monadic effects proceeds from left to right.  If at+--     some step the bind operator @('>>=')@ short-circuits (as with, e.g.,+--     'mzero' with a 'MonadPlus', or an exception with a 'MonadThrow', etc.),+--     then the evaluated effects will be from an initial portion of the+--     element sequence.+--+--     > :set -XBangPatterns+--     > import Control.Monad+--     > import Control.Monad.Trans.Class+--     > import Control.Monad.Trans.Maybe+--     > import Data.Foldable+--     > let f !_ e = when (e > 3) mzero >> lift (print e)+--     > runMaybeT $ foldlM f () [0..]+--     0+--     1+--     2+--     3+--     Nothing+--+--     Contrast this with `foldrM`, which sequences monadic effects from right+--     to left, and therefore diverges when folding an unbounded input+--     structure without ever having the opportunity to short-circuit.+--+--     > let f e _ = when (e > 3) mzero >> lift (print e)+--     > runMaybeT $ foldrM f () [0..]+--     ...hangs...+--+--     When the structure is finite `foldrM` performs the monadic effects from+--     right to left, possibly short-circuiting after processing a tail portion+--     of the element sequence.+--+--     > let f e _ = when (e < 3) mzero >> lift (print e)+--     > runMaybeT $ foldrM f () [0..5]+--     5+--     4+--     3+--     Nothing++--------------++-- $hybrid+--+-- The below folds, are neither strict reductions that produce a final answer+-- in constant space, nor lazy corecursions, and so have limited applicability.+-- They do have specialised uses, but are best avoided when in doubt.+--+-- @+-- 'foldr'' :: Foldable t => (a -> b -> b) -> b -> t a -> b+-- 'foldl'  :: Foldable t => (b -> a -> b) -> b -> t a -> b+-- 'foldl1' :: Foldable t => (a -> a -> a) -> t a -> a+-- 'foldrM' :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b+-- @+--+-- The lazy left-folds (used corecursively) and 'foldrM' (used to sequence+-- actions right-to-left) can be performant in structures whose @Foldable@+-- instances take advantage of efficient right-to-left iteration to compute+-- lazy left folds outside-in from the rightmost element.+--+-- The strict 'foldr'' is the least likely to be useful, structures that+-- support efficient sequencing /only/ right-to-left are not common.++--------------++-- $instances+--+-- #instances#+-- For many structures reasonably efficient @Foldable@ instances can be derived+-- automatically, by enabling the @DeriveFoldable@ GHC extension.  When this+-- works, it is generally not necessary to define a custom instance by hand.+-- Though in some cases one may be able to get slightly faster hand-tuned code,+-- care is required to avoid producing slower code, or code that is not+-- sufficiently lazy, strict or /lawful/.+--+-- The hand-crafted instances can get away with only defining one of 'foldr' or+-- 'foldMap'.  All the other methods have default definitions in terms of one+-- of these.  The default definitions have the expected strictness and the+-- expected asymptotic runtime and space costs, modulo small constant factors.+-- If you choose to hand-tune, benchmarking is advised to see whether you're+-- doing better than the default derived implementations, plus careful tests to+-- ensure that the custom methods are correct.+--+-- Below we construct a @Foldable@ instance for a data type representing a+-- (finite) binary tree with depth-first traversal.+--+-- >>> data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be:+--+-- >>> :{+-- instance Foldable Tree where+--    foldr f z Empty = z+--    foldr f z (Leaf x) = f x z+--    foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l+-- :}+--+-- The 'Node' case is a right fold of the left subtree whose initial+-- value is a right fold of the rest of the tree.+--+-- For example, when @f@ is @(':')@, all three cases return an immediate value,+-- respectively @z@ or a /cons cell/ holding @x@ or @l@, with the remainder the+-- structure, if any, encapsulated in a lazy thunk.  This meets the expected+-- efficient [corecursive](#corec) behaviour of 'foldr'.+--+-- Alternatively, one could define @foldMap@:+--+-- > instance Foldable Tree where+-- >    foldMap f Empty = mempty+-- >    foldMap f (Leaf x) = f x+-- >    foldMap f (Node l k r) = foldMap f l <> f k <> foldMap f r+--+-- And indeed some efficiency may be gained by directly defining both,+-- avoiding some indirection in the default definitions that express+-- one in terms of the other.  If you implement just one, likely 'foldr'+-- is the better choice.+--+-- A binary tree typically (when balanced, or randomly biased) provides equally+-- efficient access to its left and right subtrees.  This makes it possible to+-- define a `foldl` optimised for [corecursive](#corec) folds with operators+-- that are lazy in their first (left) argument.+--+-- > instance Foldable Tree where+-- >    foldr f z Empty = z+-- >    foldr f z (Leaf x) = f x z+-- >    foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l+-- >    --+-- >    foldMap f Empty = mempty+-- >    foldMap f (Leaf x) = f x+-- >    foldMap f (Node l k r) = foldMap f l <> f k <> foldMap f r+-- >    --+-- >    foldl f z Empty = z+-- >    foldl f z (Leaf x) = f z x+-- >    foldl f z (Node l k r) = foldl f (f (foldl f z l) k) r+--+-- Now left-to-right and right-to-left iteration over the structure+-- elements are equally efficient (note the mirror-order output when+-- using `foldl`):+--+-- >>> foldr (\e acc -> e : acc) [] (Node (Leaf 1) 2 (Leaf 3))+-- [1,2,3]+-- >>> foldl (\acc e -> e : acc) [] (Node (Leaf 1) 2 (Leaf 3))+-- [3,2,1]+--+-- We can carry this further, and define more non-default methods...+--+-- The structure definition actually admits trees that are unbounded on either+-- or both sides.  The only fold that can plausibly terminate for a tree+-- unbounded on both left and right is `null`, when defined as shown below.+-- The default definition in terms of `foldr` diverges if the tree is unbounded+-- on the left.  Here we define a variant that avoids travelling down the tree+-- to find the leftmost element and just examines the root node.+--+-- >    null Empty = True+-- >    null _     = False+--+-- This is a sound choice also for finite trees.+--+-- In practice, unbounded trees are quite uncommon, and can barely be said to+-- be @Foldable@.  They would typically employ breadth first traversal, and+-- would support only corecursive and short-circuit folds (diverge under strict+-- reduction).+--+-- Returning to simpler instances, defined just in terms of `foldr`, it is+-- somewhat surprising that a fairly efficient /default/ implementation of the+-- strict 'foldl'' is defined in terms of lazy `foldr` when only the latter is+-- explicitly provided by the instance.  It may be instructive to take a look+-- at how this works.++--------------++-- $strictlazy+--+-- #strictlazy#+--+-- Sometimes, it is useful for the result of applying 'foldr' to be a+-- /function/.  This is done by mapping the structure elements to functions+-- with the same argument and result types.  The per-element functions are then+-- composed to give the final result.+--+-- For example, we can /flip/ the strict left fold 'foldl'' by writing:+--+-- > foldl' f z xs = flippedFoldl' f xs z+--+-- with the function 'flippedFoldl'' defined as below, with 'seq' used to+-- ensure the strictness in the accumulator:+--+-- > flippedFoldl' f [] z = z+-- > flippedFoldl' f (x : xs) z = z `seq` flippedFoldl' f xs (f z x)+--+-- Rewriting to use lambdas, this is:+--+-- > flippedFoldl' f [] = \ b -> b+-- > flippedFoldl' f (x : xs) = \ b -> b `seq` r (f b x)+-- >     where r = flippedFoldl' f xs+--+-- The above has the form of a right fold, enabling a rewrite to:+--+-- > flippedFoldl' f = \ xs -> foldr f' id xs+-- >     where f' x r = \ b -> b `seq` r (f b x)+--+-- We can now unflip this to get 'foldl'':+--+-- > foldl' f z = \ xs -> foldr f' id xs z+-- >           -- \ xs -> flippedFoldl' f xs z+-- >   where f' x r = \ b -> b `seq` r (f b x)+--+-- The function __@foldr f' id xs@__ applied to @z@ is built corecursively, and+-- its terms are applied to an eagerly evaluated accumulator before further+-- terms are applied to the result.  As required, this runs in constant space,+-- and can be optimised to an efficient loop.+--+-- (The actual definition of 'foldl'' labels the lambdas in the definition of+-- __@f'@__ above as /oneShot/, which enables further optimisations).++--------------++-- $generative+--+-- #generative#+-- So far, we have not discussed /generative recursion/.  Unlike recursive+-- reduction or corecursion, instead of processing a sequence of elements+-- already in memory, generative recursion involves producing a possibly+-- unbounded sequence of values from an initial seed value.  The canonical+-- example of this is 'Data.List.unfoldr' for Lists, with variants available+-- for Vectors and various other structures.+--+-- A key issue with lists, when used generatively as /iterators/, rather than as+-- poor-man's containers (see [[1\]](#uselistsnot)), is that such iterators+-- tend to consume memory when used more than once.  A single traversal of a+-- list-as-iterator will run in constant space, but as soon as the list is+-- retained for reuse, its entire element sequence is stored in memory, and the+-- second traversal reads the copy, rather than regenerates the elements.  It+-- is sometimes better to recompute the elements rather than memoise the list.+--+-- Memoisation happens because the built-in Haskell list __@[]@__ is+-- represented as __data__, either empty or a /cons-cell/ holding the first+-- element and the tail of the list.  The @Foldable@ class enables a variant+-- representation of iterators as /functions/, which take an operator and a+-- starting accumulator and output a summary result.+--+-- The [@fmlist@](https://hackage.haskell.org/package/fmlist) package takes+-- this approach, by representing a list via its `foldMap` action.+--+-- Below we implement an analogous data structure using a representation+-- based on `foldr`.  This is an example of /Church encoding/+-- (named after Alonzo Church, inventor of the lambda calculus).+--+-- > {-# LANGUAGE RankNTypes #-}+-- > newtype FRList a = FR { unFR :: forall b. (a -> b -> b) -> b -> b }+--+-- The __@unFR@__ field of this type is essentially its `foldr` method+-- with the list as its first rather than last argument.  Thus we+-- immediately get a @Foldable@ instance (and a 'toList' function+-- mapping an __@FRList@__ to a regular list).+--+-- > instance Foldable FRList where+-- >     foldr f z l = unFR l f z+-- >     -- With older versions of @base@, also define sum, product, ...+-- >     -- to ensure use of the strict 'foldl''.+-- >     -- sum = foldl' (+) 0+-- >     -- ...+--+-- We can convert a regular list to an __@FRList@__ with:+--+-- > fromList :: [a] -> FRList a+-- > fromList as = FRList $ \ f z -> foldr f z as+--+-- However, reuse of an __@FRList@__ obtained in this way will typically+-- memoise the underlying element sequence.  Instead, we can define+-- __@FRList@__ terms directly:+--+-- > -- | Immediately return the initial accumulator+-- > nil :: FRList a+-- > nil = FRList $ \ _ z -> z+-- > {-# INLINE nil #-}+--+-- > -- | Fold the tail to use as an accumulator with the new initial element+-- > cons :: a -> FRList a -> FRList a+-- > cons a l = FRList $ \ f z -> f a (unFR l f z)+-- > {-# INLINE cons #-}+--+-- More crucially, we can also directly define the key building block for+-- generative recursion:+--+-- > -- | Generative recursion, dual to `foldr`.+-- > unfoldr :: (s -> Maybe (a, s)) -> s -> FRList a+-- > unfoldr g s0 = FR generate+-- >   where generate f z = loop s0+-- >           where loop s | Just (a, t) <- g s = f a (loop t)+-- >                        | otherwise = z+-- > {-# INLINE unfoldr #-}+--+-- Which can, for example, be specialised to number ranges:+--+-- > -- | Generate a range of consecutive integral values.+-- > range :: (Ord a, Integral a) => a -> a -> FRList a+-- > range lo hi =+-- >     unfoldr (\s -> if s > hi then Nothing else Just (s, s+1)) lo+-- > {-# INLINE range #-}+--+-- The program below, when compiled with optimisation:+--+-- > main :: IO ()+-- > main = do+-- >     let r :: FRList Int+-- >         r = range 1 10000000+-- >      in print (sum r, length r)+--+-- produces the expected output with no noticeable garbage-collection, despite+-- reuse of the __@FRList@__ term __@r@__.+--+-- > (50000005000000,10000000)+-- >     52,120 bytes allocated in the heap+-- >      3,320 bytes copied during GC+-- >     44,376 bytes maximum residency (1 sample(s))+-- >     25,256 bytes maximum slop+-- >          3 MiB total memory in use (0 MB lost due to fragmentation)+--+-- The Weak Head Normal Form of an __@FRList@__ is a lambda abstraction not a+-- data value, and reuse does not lead to memoisation.  Reuse of the iterator+-- above is somewhat contrived, when computing multiple folds over a common+-- list, you should generally traverse a  list only [once](#multipass).  The+-- goal is to demonstrate that the separate computations of the 'sum' and+-- 'length' run efficiently in constant space, despite reuse.  This would not+-- be the case with the list @[1..10000000]@.+--+-- This is, however, an artificially simple reduction.  More typically, there+-- are likely to be some allocations in the inner loop, but the temporary+-- storage used will be garbage-collected as needed, and overall memory+-- utilisation will remain modest and will not scale with the size of the list.+--+-- If we go back to built-in lists (i.e. __@[]@__), but avoid reuse by+-- performing reduction in a single pass, as below:+--+-- > data PairS a b = P !a !b -- We define a strict pair datatype+-- >+-- > main :: IO ()+-- > main = do+-- >     let l :: [Int]+-- >         l = [1..10000000]+-- >      in print $ average l+-- >   where+-- >     sumlen :: PairS Int Int -> Int -> PairS Int Int+-- >     sumlen (P s l) a = P (s + a) (l + 1)+-- >+-- >     average is =+-- >         let (P s l) = foldl' sumlen (P 0 0) is+-- >          in (fromIntegral s :: Double) / fromIntegral l+--+-- the result is again obtained in constant space:+--+-- > 5000000.5+-- >          102,176 bytes allocated in the heap+-- >            3,320 bytes copied during GC+-- >           44,376 bytes maximum residency (1 sample(s))+-- >           25,256 bytes maximum slop+-- >                3 MiB total memory in use (0 MB lost due to fragmentation)+--+-- (and, in fact, faster than with __@FRList@__ by a small factor).+--+-- The __@[]@__ list structure works as an efficient iterator when used+-- just once.  When space-leaks via list reuse are not a concern, and/or+-- memoisation is actually desirable, the regular list implementation is+-- likely to be faster.  This is not a suggestion to replace all your uses of+-- __@[]@__ with a generative alternative.+--+-- The __@FRList@__ type could be further extended with instances of 'Functor',+-- 'Applicative', 'Monad', 'Alternative', etc., and could then provide a+-- fully-featured list type, optimised for reuse without space-leaks.  If,+-- however, all that's required is space-efficient, re-use friendly iteration,+-- less is perhaps more, and just @Foldable@ may be sufficient.++--------------++-- $multipass+--+-- #multipass#+-- In applications where you want to compute a composite function of a+-- structure, which requires more than one aggregate as an input, it is+-- generally best to compute all the aggregates in a single pass, rather+-- than to traverse the same structure repeatedly.+--+-- The [@foldl@](http://hackage.haskell.org/package/foldl) package implements a+-- robust general framework for dealing with this situation.  If you choose to+-- to do it yourself, with a bit of care, the simplest cases are not difficult+-- to handle directly.  You just need to accumulate the individual aggregates+-- as __strict__ components of a single data type, and then apply a final+-- transformation to it to extract the composite result.  For example,+-- computing an average requires computing both the 'sum' and the 'length' of a+-- (non-empty) structure and dividing the sum by the length:+--+-- > import Data.Foldable (foldl')+-- >+-- > data PairS a b = P !a !b -- We define a strict pair datatype+-- >+-- > -- | Compute sum and length in a single pass, then reduce to the average.+-- > average :: (Foldable f, Fractional a) => f a -> a+-- > average xs =+-- >     let sumlen (P s l) a = P (s + a) (l + 1 :: Int)+-- >         (P s l) = foldl' sumlen (P 0 0) xs+-- >      in s / fromIntegral l+--+-- The above example is somewhat contrived, some structures keep track of their+-- length internally, and can return it in /O(1)/ time, so this particular+-- recipe for averages is not always the most efficient.  In general, composite+-- aggregate functions of large structures benefit from single-pass reduction.+-- This is especially the case when reuse of a list and memoisation of its+-- elements is thereby avoided.++--------------++-- $laws+-- #laws#+--+-- The type constructor 'Endo' from "Data.Monoid", associates with each type+-- __@b@__ the __@newtype@__-encapsulated type of functions mapping __@b@__ to+-- itself.  Functions from a type to itself are called /endomorphisms/, hence+-- the name /Endo/.  The type __@Endo b@__ is a 'Monoid' under function+-- composition:+--+-- > newtype Endo b = Endo { appEndo :: b -> b }+-- > instance Semigroup Endo b where+-- >     Endo f <> Endo g = Endo (f . g)+-- > instance Monoid Endo b where+-- >     mempty = Endo id+--+-- For every 'Monoid' m, we also have a 'Dual' monoid __@Dual m@__ which+-- combines elements in the opposite order:+--+-- > newtype Dual m = Dual { getDual :: m }+-- > instance Semigroup m => Semigroup Dual m where+-- >     Dual a <> Dual b = Dual (b <> a)+-- > instance Monoid m => Monoid Dual m where+-- >     mempty = Dual mempty+--+-- With the above preliminaries out of the way, 'Foldable' instances are+-- expected to satisfy the following laws:+--+-- The 'foldr' method must be equivalent in value and strictness to replacing+-- each element __@a@__ of a 'Foldable' structure with __@Endo (f a)@__,+-- composing these via 'foldMap' and applying the result to the base case+-- __@z@__:+--+-- > foldr f z t = appEndo (foldMap (Endo . f) t ) z+--+-- Likewise, the 'foldl' method must be equivalent in value and strictness+-- to composing the functions __@flip f a@__ in reverse order and applying+-- the result to the base case:+--+-- > foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z+--+-- When the elements of the structure are taken from a 'Monoid', the+-- definition of 'fold' must agree with __@foldMap id@__:+--+-- > fold = foldMap id+--+-- The 'length' method must agree with a 'foldMap' mapping each element to+-- __@Sum 1@__ (The 'Sum' type abstracts numbers as a monoid under addition).+--+-- > length = getSum . foldMap (Sum . const 1)+--+-- @sum@, @product@, @maximum@, and @minimum@ should all be essentially+-- equivalent to @foldMap@ forms, such as+--+-- > sum     = getSum     . foldMap' Sum+-- > product = getProduct . foldMap' Product+--+-- but are generally more efficient when defined more directly as:+--+-- > sum = foldl' (+) 0+-- > product = foldl' (*) 1+--+-- If the 'Foldable' structure has a 'Functor' instance, then for every+-- function __@f@__ mapping the elements into a 'Monoid', it should satisfy:+--+-- > foldMap f = fold . fmap f+--+-- which implies that+--+-- > foldMap f . fmap g = foldMap (f . g)+--++--------------++-- $notes+--+-- #notes#+-- Since 'Foldable' does not have 'Functor' as a superclass, it is possible to+-- define 'Foldable' instances for structures that constrain their element+-- types.  Therefore, __@Set@__ can be 'Foldable', even though sets keep their+-- elements in ascending order.  This requires the elements to be comparable,+-- which precludes defining a 'Functor' instance for @Set@.+--+-- The 'Foldable' class makes it possible to use idioms familiar from the @List@+-- type with container structures that are better suited to the task at hand.+-- This supports use of more appropriate 'Foldable' data types, such as @Seq@,+-- @Set@, @NonEmpty@, etc., without requiring new idioms (see+-- [[1\]](#uselistsnot) for when not to use lists).+--+-- The more general methods of the 'Foldable' class are now exported by the+-- "Prelude" in place of the original List-specific methods (see the+-- [FTP Proposal](https://wiki.haskell.org/Foldable_Traversable_In_Prelude)).+-- The List-specific variants are for now still available in "GHC.OldList", but+-- that module is intended only as a transitional aid, and may be removed in+-- the future.+--+-- Surprises can arise from the @Foldable@ instance of the 2-tuple @(a,)@ which+-- now behaves as a 1-element @Foldable@ container in its second slot.  In+-- contexts where a specific monomorphic type is expected, and you want to be+-- able to rely on type errors to guide refactoring, it may make sense to+-- define and use less-polymorphic variants of some of the @Foldable@ methods.+--+-- Below are two examples showing a definition of a reusable less-polymorphic+-- 'sum' and a one-off in-line specialisation of 'length':+--+-- > {-# LANGUAGE TypeApplications #-}+-- >+-- > mySum :: Num a => [a] -> a+-- > mySum = sum+-- >+-- > type SlowVector a = [a]+-- > slowLength :: SlowVector -> Int+-- > slowLength v = length @[] v+--+-- In both cases, if the data type to which the function is applied changes+-- to something other than a list, the call-site will no longer compile until+-- appropriate changes are made.++-- $linear+--+-- It is perhaps worth noting that since the __`elem`__ function in the+-- 'Foldable' class carries only an __`Eq`__ constraint on the element type,+-- search for the presence or absence of an element in the structure generally+-- takes /O(n)/ time, even for ordered structures like __@Set@__ that are+-- potentially capable of performing the search faster.  (The @member@ function+-- of the @Set@ module carries an `Ord` constraint, and can perform the search+-- in /O(log n)/ time).+--+-- An alternative to Foldable's __`elem`__ method is required in order to+-- abstract potentially faster than linear search over general container+-- structures.  This can be achieved by defining an additional type class (e.g.+-- @HasMember@ below).  Instances of such a type class (that are also+-- `Foldable') can employ the `elem` linear search as a last resort, when+-- faster search is not supported.+--+-- > {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- >+-- > import qualified Data.Set as Set+-- >+-- > class Eq a => HasMember t a where+-- >     member :: a -> t a -> Bool+-- >+-- > instance Eq a => HasMember [] a where+-- >     member = elem+-- > [...]+-- > instance Ord a => HasMember Set.Set a where+-- >     member = Set.member+--+-- The above suggests that 'elem' may be a misfit in the 'Foldable' class.+-- Alternative design ideas are solicited on GHC's bug tracker via issue+-- [\#20421](https://gitlab.haskell.org/ghc/ghc/-/issues/20421).+--+-- Note that some structure-specific optimisations may of course be possible+-- directly in the corresponding @Foldable@ instance, e.g. with @Set@ the size+-- of the set is known in advance, without iterating to count the elements, and+-- its `length` instance takes advantage of this to return the size directly.++--------------++-- $also+--+--  * [1] #uselistsnot# \"When You Should Use Lists in Haskell (Mostly, You Should Not)\",+--    by Johannes Waldmann,+--    in arxiv.org, Programming Languages (cs.PL), at+--    <https://arxiv.org/abs/1808.08329>.+--+--  * [2] \"The Essence of the Iterator Pattern\",+--    by Jeremy Gibbons and Bruno Oliveira,+--    in /Mathematically-Structured Functional Programming/, 2006, online at+--    <http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/#iterator>.+--+--  * [3] \"A tutorial on the universality and expressiveness of fold\",+--    by Graham Hutton, J\. Functional Programming 9 (4): 355–372, July 1999,+--    online at <http://www.cs.nott.ac.uk/~pszgmh/fold.pdf>.
+ src/Data/Foldable1.hs view
@@ -0,0 +1,620 @@+-- |+-- Copyright: Edward Kmett, Oleg Grenrus+-- License: BSD-3-Clause+--+-- A class of non-empty data structures that can be folded to a summary value.+--+-- @since 4.18.0.0++{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE Trustworthy                #-}+{-# LANGUAGE TypeOperators              #-}++module Data.Foldable1 (+    Foldable1(..),+    foldr1, foldr1',+    foldl1, foldl1',+    intercalate1,+    foldrM1,+    foldlM1,+    foldrMapM1,+    foldlMapM1,+    maximumBy,+    minimumBy,+    ) where++import GHC.Internal.Data.Foldable      (Foldable, foldlM, foldr)+import GHC.Internal.Data.List          (foldl, foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup+       (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..),+       Semigroup (..), Sum (..))+import GHC.Tuple (Solo (..))+import Prelude+       (Maybe (..), Monad (..), Ord, Ordering (..), id, seq, ($!), ($), (.),+       (=<<), flip, const, error)++import qualified Data.List.NonEmpty as NE++import Data.Complex (Complex (..))+import GHC.Generics+       (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..))++import GHC.Internal.Data.Ord (Down (..))++import qualified GHC.Internal.Data.Monoid as Mon++-- Instances+import Data.Functor.Compose          (Compose (..))+import GHC.Internal.Data.Functor.Identity         (Identity (..))++import qualified Data.Functor.Product as Functor+import qualified Data.Functor.Sum     as Functor++-- coerce+import GHC.Internal.Data.Coerce (Coercible, coerce)++-- $setup+-- >>> import Prelude hiding (foldr1, foldl1, head, last, minimum, maximum)+-- >>> import Data.List.NonEmpty (NonEmpty(..))+-- >>> import Data.Monoid (Sum(..))+-- >>> import Data.Functor.Identity++-------------------------------------------------------------------------------+-- Foldable1 type class+-------------------------------------------------------------------------------++-- | Non-empty data structures that can be folded.+--+-- @since 4.18.0.0+class Foldable t => Foldable1 t where+    {-# MINIMAL foldMap1 | foldrMap1 #-}++    -- At some point during design it was possible to define this class using+    -- only 'toNonEmpty'. But it seems a bad idea in general.+    --+    -- So currently we require either foldMap1 or foldrMap1+    --+    -- * foldMap1 defined using foldrMap1+    -- * foldrMap1 defined using foldMap1+    --+    -- One can always define an instance using the following pattern:+    --+    --     toNonEmpty = ...+    --     foldMap f     = foldMap f     . toNonEmpty+    --     foldrMap1 f g = foldrMap1 f g . toNonEmpty++    -- | Given a structure with elements whose type is a 'Semigroup', combine+    -- them via the semigroup's @('<>')@ operator. This fold is+    -- right-associative and lazy in the accumulator. When you need a strict+    -- left-associative fold, use 'foldMap1'' instead, with 'id' as the map.+    --+    -- @since 4.18.0.0+    fold1 :: Semigroup m => t m -> m+    fold1 = foldMap1 id++    -- | Map each element of the structure to a semigroup, and combine the+    -- results with @('<>')@. This fold is right-associative and lazy in the+    -- accumulator. For strict left-associative folds consider 'foldMap1''+    -- instead.+    --+    -- >>> foldMap1 (:[]) (1 :| [2, 3, 4])+    -- [1,2,3,4]+    --+    -- @since 4.18.0.0+    foldMap1 :: Semigroup m => (a -> m) -> t a -> m+    foldMap1 f = foldrMap1 f (\a m -> f a <> m)++    -- | A left-associative variant of 'foldMap1' that is strict in the+    -- accumulator. Use this for strict reduction when partial results are+    -- merged via @('<>')@.+    --+    -- >>> foldMap1' Sum (1 :| [2, 3, 4])+    -- Sum {getSum = 10}+    --+    -- @since 4.18.0.0+    foldMap1' :: Semigroup m => (a -> m) -> t a -> m+    foldMap1' f = foldlMap1' f (\m a -> m <> f a)++    -- | 'NonEmpty' list of elements of a structure, from left to right.+    --+    -- >>> toNonEmpty (Identity 2)+    -- 2 :| []+    --+    -- @since 4.18.0.0+    toNonEmpty :: t a -> NonEmpty a+    toNonEmpty = runNonEmptyDList . foldMap1 singleton++    -- | The largest element of a non-empty structure. This function is+    -- equivalent to @'foldr1' 'Data.Ord.max'@, and its behavior on structures+    -- with multiple largest elements depends on the relevant implementation of+    -- 'Data.Ord.max'. For the default implementation of 'Data.Ord.max' (@max x+    -- y = if x <= y then y else x@), structure order is used as a tie-breaker:+    -- if there are multiple largest elements, the rightmost of them is chosen+    -- (this is equivalent to @'maximumBy' 'Data.Ord.compare'@).+    --+    -- >>> maximum (32 :| [64, 8, 128, 16])+    -- 128+    --+    -- @since 4.18.0.0+    maximum :: Ord a => t a -> a+    maximum = getMax #. foldMap1' Max++    -- | The least element of a non-empty structure. This function is+    -- equivalent to @'foldr1' 'Data.Ord.min'@, and its behavior on structures+    -- with multiple largest elements depends on the relevant implementation of+    -- 'Data.Ord.min'. For the default implementation of 'Data.Ord.min' (@min x+    -- y = if x <= y then x else y@), structure order is used as a tie-breaker:+    -- if there are multiple least elements, the leftmost of them is chosen+    -- (this is equivalent to @'minimumBy' 'Data.Ord.compare'@).+    --+    -- >>> minimum (32 :| [64, 8, 128, 16])+    -- 8+    --+    -- @since 4.18.0.0+    minimum :: Ord a => t a -> a+    minimum = getMin #. foldMap1' Min++    -- | The first element of a non-empty structure.+    --+    -- >>> head (1 :| [2, 3, 4])+    -- 1+    --+    -- @since 4.18.0.0+    head :: t a -> a+    head = getFirst #. foldMap1 First++    -- | The last element of a non-empty structure.+    --+    -- >>> last (1 :| [2, 3, 4])+    -- 4+    --+    -- @since 4.18.0.0+    last :: t a -> a+    last = getLast #. foldMap1 Last++    -- | Right-associative fold of a structure, lazy in the accumulator.+    --+    -- In case of 'NonEmpty' lists, 'foldrMap1', when given a function @f@, a+    -- binary operator @g@, and a list, reduces the list using @g@ from right to+    -- left applying @f@ to the rightmost element:+    --+    -- > foldrMap1 f g (x1 :| [x2, ..., xn1, xn]) == x1 `g` (x2 `g` ... (xn1 `g` (f xn))...)+    --+    -- Note that since the head of the resulting expression is produced by+    -- an application of @g@ to the first element of the list, if @g@ is lazy+    -- in its right argument, 'foldrMap1' can produce a terminating expression+    -- from an unbounded list.+    --+    -- For a general 'Foldable1' structure this should be semantically identical+    -- to:+    --+    -- @foldrMap1 f g = foldrMap1 f g . 'toNonEmpty'@+    --+    -- @since 4.18.0.0+    foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b+    foldrMap1 f g xs =+        appFromMaybe (foldMap1 (FromMaybe #. h) xs) Nothing+      where+        h a Nothing  = f a+        h a (Just b) = g a b++    -- | Left-associative fold of a structure but with strict application of the+    -- operator.+    --+    -- 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 structure to a single strict result.+    --+    -- For a general 'Foldable1' structure this should be semantically identical+    -- to:+    --+    -- @foldlMap1' f z = foldlMap1' f z . 'toNonEmpty'@+    --+    -- @since 4.18.0.0+    foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b+    foldlMap1' f g xs =+        foldrMap1 f' g' xs SNothing+      where+        -- f' :: a -> SMaybe b -> b+        f' a SNothing  = f a+        f' a (SJust b) = g b a++        -- g' :: a -> (SMaybe b -> b) -> SMaybe b -> b+        g' a x SNothing  = x $! SJust (f a)+        g' a x (SJust b) = x $! SJust (g b a)++    -- | Left-associative fold of a structure, lazy in the accumulator.  This is+    -- rarely what you want, but can work well for structures with efficient+    -- right-to-left sequencing and an operator that is lazy in its left+    -- argument.+    --+    -- In case of 'NonEmpty' lists, 'foldlMap1', when given a function @f@, a+    -- binary operator @g@, and a list, reduces the list using @g@ from left to+    -- right applying @f@ to the leftmost element:+    --+    -- > foldlMap1 f g (x1 :| [x2, ..., xn]) == (...(((f x1) `g` x2) `g`...) `g` xn+    --+    -- Note that to produce the outermost application of the operator the entire+    -- input list must be traversed. This means that 'foldlMap1' will diverge if+    -- given an infinite list.+    --+    -- If you want an efficient strict left-fold, you probably want to use+    -- 'foldlMap1''  instead of 'foldlMap1'. The reason for this is that the+    -- latter does not force the /inner/ results (e.g. @(f x1) \`g\` x2@ in the+    -- above example) before applying them to the operator (e.g. to+    -- @(\`g\` x3)@). This results in a thunk chain \(O(n)\) elements long,+    -- which then must be evaluated from the outside-in.+    --+    -- For a general 'Foldable1' structure this should be semantically identical+    -- to:+    --+    -- @foldlMap1 f g = foldlMap1 f g . 'toNonEmpty'@+    --+    -- @since 4.18.0.0+    foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b+    foldlMap1 f g xs =+        appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) #. h) xs)) Nothing+      where+        h a Nothing  = f a+        h a (Just b) = g b a++    -- | 'foldrMap1'' is a variant of 'foldrMap1' that performs strict reduction+    -- from right to left, i.e. starting with the right-most element. The input+    -- structure /must/ be finite, otherwise 'foldrMap1'' runs out of space+    -- (/diverges/).+    --+    -- If you want a strict right fold in constant space, you need a structure+    -- that supports faster than \(O(n)\) access to the right-most element.+    --+    -- This method does not run in constant space for structures such as+    -- 'NonEmpty' lists that don't support efficient right-to-left iteration and+    -- so require \(O(n)\) space to perform right-to-left reduction. Use of this+    -- method with such a structure is a hint that the chosen structure may be a+    -- poor fit for the task at hand. If the order in which the elements are+    -- combined is not important, use 'foldlMap1'' instead.+    --+    -- @since 4.18.0.0+    foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b+    foldrMap1' f g xs =+        foldlMap1 f' g' xs SNothing+      where+        f' a SNothing  = f a+        f' a (SJust b) = g a b++        g' bb a SNothing  = bb $! SJust (f a)+        g' bb a (SJust b) = bb $! SJust (g a b)++-------------------------------------------------------------------------------+-- Combinators+-------------------------------------------------------------------------------++-- | A variant of 'foldrMap1' where the rightmost element maps to itself.+--+-- @since 4.18.0.0+foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a+foldr1 = foldrMap1 id+{-# INLINE foldr1 #-}++-- | A variant of 'foldrMap1'' where the rightmost element maps to itself.+--+-- @since 4.18.0.0+foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a+foldr1' = foldrMap1' id+{-# INLINE foldr1' #-}++-- | A variant of 'foldlMap1' where the leftmost element maps to itself.+--+-- @since 4.18.0.0+foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a+foldl1 = foldlMap1 id+{-# INLINE foldl1 #-}++-- | A variant of 'foldlMap1'' where the leftmost element maps to itself.+--+-- @since 4.18.0.0+foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a+foldl1' = foldlMap1' id+{-# INLINE foldl1' #-}++-- | Insert an @m@ between each pair of @t m@.+--+-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"]+-- "hello, how, are, you"+--+-- >>> intercalate1 ", " $ "hello" :| []+-- "hello"+--+-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"]+-- "IAmFineYou?"+--+-- @since 4.18.0.0+intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m+intercalate1 = flip intercalateMap1 id++intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m+intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f)++-- | Monadic fold over the elements of a non-empty structure,+-- associating to the right, i.e. from right to left.+--+-- @since 4.18.0.0+foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a+foldrM1 = foldrMapM1 return++-- | Map variant of 'foldrM1'.+--+-- @since 4.18.0.0+foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b+foldrMapM1 g f = go . toNonEmpty+  where+    go (e:|es) =+      case es of+        []   -> g e+        x:xs -> f e =<< go (x:|xs)++-- | Monadic fold over the elements of a non-empty structure,+-- associating to the left, i.e. from left to right.+--+-- @since 4.18.0.0+foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a+foldlM1 = foldlMapM1 return++-- | Map variant of 'foldlM1'.+--+-- @since 4.18.0.0+foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b+foldlMapM1 g f t = g x >>= \y -> foldlM f y xs+  where x:|xs = toNonEmpty t++-- | The largest element of a non-empty structure with respect to the+-- given comparison function. Structure order is used as a tie-breaker: if+-- there are multiple largest elements, the rightmost of them is chosen.+--+-- @since 4.18.0.0+maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a+maximumBy cmp = foldl1' max'+  where max' x y = case cmp x y of+                        GT -> x+                        _  -> y++-- | The least element of a non-empty structure with respect to the+-- given comparison function. Structure order is used as a tie-breaker: if+-- there are multiple least elements, the leftmost of them is chosen.+--+-- @since 4.18.0.0+minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a+minimumBy cmp = foldl1' min'+  where min' x y = case cmp x y of+                        GT -> y+                        _  -> x++-------------------------------------------------------------------------------+-- Auxiliary types+-------------------------------------------------------------------------------++-- | Used for default toNonEmpty implementation.+newtype NonEmptyDList a = NEDL { unNEDL :: [a] -> NonEmpty a }++instance Semigroup (NonEmptyDList a) where+  xs <> ys = NEDL (unNEDL xs . NE.toList . unNEDL ys)+  {-# INLINE (<>) #-}++-- | Create dlist with a single element+singleton :: a -> NonEmptyDList a+singleton = NEDL #. (:|)++-- | Convert a dlist to a non-empty list+runNonEmptyDList :: NonEmptyDList a -> NonEmpty a+runNonEmptyDList = ($ []) . unNEDL+{-# INLINE runNonEmptyDList #-}++-- | Used for foldrMap1 and foldlMap1 definitions+newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b }++instance Semigroup (FromMaybe b) where+    FromMaybe f <> FromMaybe g = FromMaybe (f . Just . g)++-- | Strict maybe, used to implement default foldlMap1' etc.+data SMaybe a = SNothing | SJust !a++-- | Used to implement intercalate1/Map+newtype JoinWith a = JoinWith {joinee :: (a -> a)}++instance Semigroup a => Semigroup (JoinWith a) where+  JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j++-------------------------------------------------------------------------------+-- Instances for misc base types+-------------------------------------------------------------------------------++-- | @since 4.18.0.0+instance Foldable1 NonEmpty where+    foldMap1 f (x :| xs) = go (f x) xs where+        go y [] = y+        go y (z : zs) = y <> go (f z) zs++    foldMap1' f (x :| xs) = foldl' (\m y -> m <> f y) (f x) xs++    toNonEmpty = id++    foldrMap1 g f (x :| xs) = go x xs where+        go y [] = g y+        go y (z : zs) = f y (go z zs)++    foldlMap1  g f (x :| xs) = foldl f (g x) xs+    foldlMap1' g f (x :| xs) = let gx = g x in gx `seq` foldl' f gx xs++    head = NE.head+    last = NE.last++-- | @since 4.18.0.0+instance Foldable1 Down where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 Complex where+    foldMap1 f (x :+ y) = f x <> f y++    toNonEmpty (x :+ y) = x :| y : []++-------------------------------------------------------------------------------+-- Instances for tuples+-------------------------------------------------------------------------------++-- 3+ tuples are not Foldable/Traversable++-- | @since 4.18.0.0+instance Foldable1 Solo where+    foldMap1 f (MkSolo y) = f y+    toNonEmpty (MkSolo x) = x :| []+    minimum (MkSolo x) = x+    maximum (MkSolo x) = x+    head (MkSolo x) = x+    last (MkSolo x) = x++-- | @since 4.18.0.0+instance Foldable1 ((,) a) where+    foldMap1 f (_, y) = f y+    toNonEmpty (_, x) = x :| []+    minimum (_, x) = x+    maximum (_, x) = x+    head (_, x) = x+    last (_, x) = x++-------------------------------------------------------------------------------+-- Monoid / Semigroup instances+-------------------------------------------------------------------------------++-- | @since 4.18.0.0+instance Foldable1 Dual where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 Sum where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 Product where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 Min where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 Max where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 First where+    foldMap1 = coerce++-- | @since 4.18.0.0+instance Foldable1 Last where+    foldMap1 = coerce++-- | @since 4.18.0.0+deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f)++-- | @since 4.18.0.0+deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f)++-------------------------------------------------------------------------------+-- GHC.Generics instances+-------------------------------------------------------------------------------++-- | @since 4.18.0.0+instance Foldable1 V1 where+    foldMap1 _ x = x `seq` error "foldMap1 @V1"++-- | @since 4.18.0.0+instance Foldable1 Par1 where+    foldMap1 = coerce++-- | @since 4.18.0.0+deriving instance Foldable1 f => Foldable1 (Rec1 f)++-- | @since 4.18.0.0+deriving instance Foldable1 f => Foldable1 (M1 i c f)++-- | @since 4.18.0.0+instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where+    foldMap1 f (L1 x) = foldMap1 f x+    foldMap1 f (R1 y) = foldMap1 f y++-- | @since 4.18.0.0+instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where+    foldMap1 f (x :*: y) = foldMap1 f x <> foldMap1 f y++-- | @since 4.18.0.0+instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where+    foldMap1 f = foldMap1 (foldMap1 f) . unComp1++-------------------------------------------------------------------------------+-- Extra instances+-------------------------------------------------------------------------------++-- | @since 4.18.0.0+instance Foldable1 Identity where+    foldMap1      = coerce++    foldrMap1  g _ = coerce g+    foldrMap1' g _ = coerce g+    foldlMap1  g _ = coerce g+    foldlMap1' g _ = coerce g++    toNonEmpty (Identity x) = x :| []++    last    = coerce+    head    = coerce+    minimum = coerce+    maximum = coerce++-- | It would be enough for either half of a product to be 'Foldable1'.+-- Other could be 'Foldable'.+instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where+    foldMap1 f (Functor.Pair x y)    = foldMap1 f x <> foldMap1 f y+    foldrMap1 g f (Functor.Pair x y) = foldr f (foldrMap1 g f y) x++    head (Functor.Pair x _) = head x+    last (Functor.Pair _ y) = last y++-- | @since 4.18.0.0+instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where+    foldMap1 f (Functor.InL x) = foldMap1 f x+    foldMap1 f (Functor.InR y) = foldMap1 f y++    foldrMap1 g f (Functor.InL x) = foldrMap1 g f x+    foldrMap1 g f (Functor.InR y) = foldrMap1 g f y++    toNonEmpty (Functor.InL x) = toNonEmpty x+    toNonEmpty (Functor.InR y) = toNonEmpty y++    head (Functor.InL x) = head x+    head (Functor.InR y) = head y+    last (Functor.InL x) = last x+    last (Functor.InR y) = last y++    minimum (Functor.InL x) = minimum x+    minimum (Functor.InR y) = minimum y+    maximum (Functor.InL x) = maximum x+    maximum (Functor.InR y) = maximum y++-- | @since 4.18.0.0+instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where+    foldMap1 f = foldMap1 (foldMap1 f) . getCompose++    foldrMap1 f g = foldrMap1 (foldrMap1 f g) (\xs x -> foldr g x xs) . getCompose++    head = head . head . getCompose+    last = last . last . getCompose++(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c+(#.) _f = coerce
+ src/Data/Function.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Function+-- Copyright   :  Nils Anders Danielsson 2006+--             ,  Alexander Berntsen     2014+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Simple combinators working solely on and with functions.+--++module Data.Function+    (-- *  "Prelude" re-exports+     id,+     const,+     (.),+     flip,+     ($),+     -- *  Other combinators+     (&),+     fix,+     on,+     applyWhen+     ) where++import GHC.Internal.Data.Function
+ src/Data/Functor.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Functor+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+--+-- A type @f@ is a Functor if it provides a function 'fmap' which, given any types @a@ and @b@,+-- lets you apply any function of type @(a -> b)@ to turn an @f a@ into an @f b@, preserving the+-- structure of @f@.+module Data.Functor+    (Functor(..),+     ($>),+     (<$>),+     (<&>),+     unzip,+     void+     ) where++import GHC.Internal.Data.Functor
+ src/Data/Functor/Classes.hs view
@@ -0,0 +1,1446 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE DefaultSignatures    #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE Safe                 #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE QuantifiedConstraints #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Classes+-- Copyright   :  (c) Ross Paterson 2013+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- 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+-- >   readPrec     = readPrec1+-- >   readListPrec = readListPrecDefault+-- > 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, readPrec1,+    liftReadListDefault, liftReadListPrecDefault,+    Show1(..), showsPrec1,+    -- ** For binary constructors+    Eq2(..), eq2,+    Ord2(..), compare2,+    Read2(..), readsPrec2, readPrec2,+    liftReadList2Default, liftReadListPrec2Default,+    Show2(..), showsPrec2,+    -- * Helper functions+    -- $example+    readsData, readData,+    readsUnaryWith, readUnaryWith,+    readsBinaryWith, readBinaryWith,+    showsUnaryWith,+    showsBinaryWith,+    -- ** Obsolete helpers+    readsUnary,+    readsUnary1,+    readsBinary1,+    showsUnary,+    showsUnary1,+    showsBinary1,+  ) where++import Control.Applicative (Alternative((<|>)), Const(Const))++import GHC.Internal.Data.Functor.Identity (Identity(Identity))+import GHC.Internal.Data.Proxy (Proxy(Proxy))+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Internal.Data.Ord (Down(Down))+import Data.Complex (Complex((:+)))++import GHC.Generics (Generic1(..), Generically1(..), V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..), URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord)+import GHC.Tuple (Solo (..))+import GHC.Internal.Read (expectP, list, paren, readField)+import GHC.Internal.Show (appPrec)++import GHC.Internal.Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec, pfail)+import GHC.Internal.Text.Read (Read(..), parens, prec, step, reset)+import GHC.Internal.Text.Read.Lex (Lexeme(..))+import GHC.Internal.Text.Show (showListWith)+import Prelude++-- $setup+-- >>> import Prelude+-- >>> import Data.Complex (Complex (..))+-- >>> import GHC.Internal.Text.ParserCombinators.ReadPrec++-- | Lifting of the 'Eq' class to unary type constructors.+--+-- Any instance should be subject to the following law that canonicity+-- is preserved:+--+-- @liftEq (==)@ = @(==)@+--+-- This class therefore represents the generalization of 'Eq' by+-- decomposing its main method into a canonical lifting on a canonical+-- inner method, so that the lifting can be reused for other arguments+-- than the canonical one.+--+-- @since 4.9.0.0+class (forall a. Eq a => Eq (f a)) => 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.+    --+    -- @since 4.9.0.0+    liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool+    default liftEq+        :: (f ~ f' c, Eq2 f', Eq c)+        => (a -> b -> Bool) -> f a -> f b -> Bool+    liftEq = liftEq2 (==)++-- | Lift the standard @('==')@ function through the type constructor.+--+-- @since 4.9.0.0+eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool+eq1 = liftEq (==)++-- | Lifting of the 'Ord' class to unary type constructors.+--+-- Any instance should be subject to the following law that canonicity+-- is preserved:+--+-- @liftCompare compare@ = 'compare'+--+-- This class therefore represents the generalization of 'Ord' by+-- decomposing its main method into a canonical lifting on a canonical+-- inner method, so that the lifting can be reused for other arguments+-- than the canonical one.+--+-- @since 4.9.0.0+class (Eq1 f, forall a. Ord a => Ord (f a)) => 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.+    --+    -- @since 4.9.0.0+    liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering+    default liftCompare+        :: (f ~ f' c, Ord2 f', Ord c)+        => (a -> b -> Ordering) -> f a -> f b -> Ordering+    liftCompare = liftCompare2 compare++-- | Lift the standard 'compare' function through the type constructor.+--+-- @since 4.9.0.0+compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering+compare1 = liftCompare compare++-- | Lifting of the 'Read' class to unary type constructors.+--+-- Any instance should be subject to the following laws that canonicity+-- is preserved:+--+-- @liftReadsPrec readsPrec readList@ = 'readsPrec'+--+-- @liftReadList readsPrec readList@ = 'readList'+--+-- @liftReadPrec readPrec readListPrec@ = 'readPrec'+--+-- @liftReadListPrec readPrec readListPrec@ = 'readListPrec'+--+-- This class therefore represents the generalization of 'Read' by+-- decomposing it's methods into a canonical lifting on a canonical+-- inner method, so that the lifting can be reused for other arguments+-- than the canonical one.+--+-- Both 'liftReadsPrec' and 'liftReadPrec' exist to match the interface+-- provided in the 'Read' type class, but it is recommended to implement+-- 'Read1' instances using 'liftReadPrec' as opposed to 'liftReadsPrec', since+-- the former is more efficient than the latter. For example:+--+-- @+-- instance 'Read1' T where+--   'liftReadPrec'     = ...+--   'liftReadListPrec' = 'liftReadListPrecDefault'+-- @+--+-- For more information, refer to the documentation for the 'Read' class.+--+-- @since 4.9.0.0+class (forall a. Read a => Read (f a)) => Read1 f where+    {-# MINIMAL liftReadsPrec | liftReadPrec #-}++    -- | 'readsPrec' function for an application of the type constructor+    -- based on 'readsPrec' and 'readList' functions for the argument type.+    --+    -- @since 4.9.0.0+    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)+    liftReadsPrec rp rl = readPrec_to_S $+        liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))++    -- | '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.+    --+    -- @since 4.9.0.0+    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]+    liftReadList rp rl = readPrec_to_S+        (list $ liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0++    -- | 'readPrec' function for an application of the type constructor+    -- based on 'readPrec' and 'readListPrec' functions for the argument type.+    --+    -- @since 4.10.0.0+    liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)+    liftReadPrec rp rl = readS_to_Prec $+        liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0)++    -- | 'readListPrec' function for an application of the type constructor+    -- based on 'readPrec' and 'readListPrec' functions for the argument type.+    --+    -- The default definition uses 'liftReadList'. Instances that define+    -- 'liftReadPrec' should also define 'liftReadListPrec' as+    -- 'liftReadListPrecDefault'.+    --+    -- @since 4.10.0.0+    liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]+    liftReadListPrec rp rl = readS_to_Prec $ \_ ->+        liftReadList (readPrec_to_S rp) (readPrec_to_S rl 0)++-- | Lift the standard 'readsPrec' and 'readList' functions through the+-- type constructor.+--+-- @since 4.9.0.0+readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)+readsPrec1 = liftReadsPrec readsPrec readList++-- | Lift the standard 'readPrec' and 'readListPrec' functions through the+-- type constructor.+--+-- @since 4.10.0.0+readPrec1 :: (Read1 f, Read a) => ReadPrec (f a)+readPrec1 = liftReadPrec readPrec readListPrec++-- | A possible replacement definition for the 'liftReadList' method.+-- This is only needed for 'Read1' instances where 'liftReadListPrec' isn't+-- defined as 'liftReadListPrecDefault'.+--+-- @since 4.10.0.0+liftReadListDefault :: Read1 f => (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]+liftReadListDefault rp rl = readPrec_to_S+    (liftReadListPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0++-- | A possible replacement definition for the 'liftReadListPrec' method,+-- defined using 'liftReadPrec'.+--+-- @since 4.10.0.0+liftReadListPrecDefault :: Read1 f => ReadPrec a -> ReadPrec [a]+                        -> ReadPrec [f a]+liftReadListPrecDefault rp rl = list (liftReadPrec rp rl)++-- | Lifting of the 'Show' class to unary type constructors.+--+-- Any instance should be subject to the following laws that canonicity+-- is preserved:+--+-- @liftShowsPrec showsPrec showList@ = 'showsPrec'+--+-- @liftShowList showsPrec showList@ = 'showList'+--+-- This class therefore represents the generalization of 'Show' by+-- decomposing it's methods into a canonical lifting on a canonical+-- inner method, so that the lifting can be reused for other arguments+-- than the canonical one.+--+-- @since 4.9.0.0+class (forall a. Show a => Show (f a)) => Show1 f where+    -- | 'showsPrec' function for an application of the type constructor+    -- based on 'showsPrec' and 'showList' functions for the argument type.+    --+    -- @since 4.9.0.0+    liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->+        Int -> f a -> ShowS+    default liftShowsPrec+        :: (f ~ f' b, Show2 f', Show b)+        => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS+    liftShowsPrec = liftShowsPrec2 showsPrec showList++    -- | '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.+    --+    -- @since 4.9.0.0+    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.+--+-- @since 4.9.0.0+showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS+showsPrec1 = liftShowsPrec showsPrec showList++-- | Lifting of the 'Eq' class to binary type constructors.+--+-- @since 4.9.0.0+class (forall a. Eq a => Eq1 (f a)) => 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.+    --+    -- @since 4.9.0.0+    liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool++-- | Lift the standard @('==')@ function through the type constructor.+--+-- @since 4.9.0.0+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.+--+-- @since 4.9.0.0+class (Eq2 f, forall a. Ord a => Ord1 (f a)) => 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.+    --+    -- @since 4.9.0.0+    liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->+        f a c -> f b d -> Ordering++-- | Lift the standard 'compare' function through the type constructor.+--+-- @since 4.9.0.0+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.+--+-- Both 'liftReadsPrec2' and 'liftReadPrec2' exist to match the interface+-- provided in the 'Read' type class, but it is recommended to implement+-- 'Read2' instances using 'liftReadPrec2' as opposed to 'liftReadsPrec2',+-- since the former is more efficient than the latter. For example:+--+-- @+-- instance 'Read2' T where+--   'liftReadPrec2'     = ...+--   'liftReadListPrec2' = 'liftReadListPrec2Default'+-- @+--+-- For more information, refer to the documentation for the 'Read' class.+--+-- @since 4.9.0.0+class (forall a. Read a => Read1 (f a)) => Read2 f where+    {-# MINIMAL liftReadsPrec2 | liftReadPrec2 #-}++    -- | 'readsPrec' function for an application of the type constructor+    -- based on 'readsPrec' and 'readList' functions for the argument types.+    --+    -- @since 4.9.0.0+    liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->+        (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)+    liftReadsPrec2 rp1 rl1 rp2 rl2 = readPrec_to_S $+        liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))+                      (readS_to_Prec rp2) (readS_to_Prec (const rl2))++    -- | '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.+    --+    -- @since 4.9.0.0+    liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->+        (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]+    liftReadList2 rp1 rl1 rp2 rl2 = readPrec_to_S+       (list $ liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))+                             (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0++    -- | 'readPrec' function for an application of the type constructor+    -- based on 'readPrec' and 'readListPrec' functions for the argument types.+    --+    -- @since 4.10.0.0+    liftReadPrec2 :: ReadPrec a -> ReadPrec [a] ->+        ReadPrec b -> ReadPrec [b] -> ReadPrec (f a b)+    liftReadPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $+        liftReadsPrec2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)+                       (readPrec_to_S rp2) (readPrec_to_S rl2 0)++    -- | 'readListPrec' function for an application of the type constructor+    -- based on 'readPrec' and 'readListPrec' functions for the argument types.+    --+    -- The default definition uses 'liftReadList2'. Instances that define+    -- 'liftReadPrec2' should also define 'liftReadListPrec2' as+    -- 'liftReadListPrec2Default'.+    --+    -- @since 4.10.0.0+    liftReadListPrec2 :: ReadPrec a -> ReadPrec [a] ->+        ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]+    liftReadListPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $ \_ ->+        liftReadList2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)+                      (readPrec_to_S rp2) (readPrec_to_S rl2 0)++-- | Lift the standard 'readsPrec' function through the type constructor.+--+-- @since 4.9.0.0+readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)+readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList++-- | Lift the standard 'readPrec' function through the type constructor.+--+-- @since 4.10.0.0+readPrec2 :: (Read2 f, Read a, Read b) => ReadPrec (f a b)+readPrec2 = liftReadPrec2 readPrec readListPrec readPrec readListPrec++-- | A possible replacement definition for the 'liftReadList2' method.+-- This is only needed for 'Read2' instances where 'liftReadListPrec2' isn't+-- defined as 'liftReadListPrec2Default'.+--+-- @since 4.10.0.0+liftReadList2Default :: Read2 f => (Int -> ReadS a) -> ReadS [a] ->+    (Int -> ReadS b) -> ReadS [b] ->ReadS [f a b]+liftReadList2Default rp1 rl1 rp2 rl2 = readPrec_to_S+    (liftReadListPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))+                       (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0++-- | A possible replacement definition for the 'liftReadListPrec2' method,+-- defined using 'liftReadPrec2'.+--+-- @since 4.10.0.0+liftReadListPrec2Default :: Read2 f => ReadPrec a -> ReadPrec [a] ->+    ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]+liftReadListPrec2Default rp1 rl1 rp2 rl2 = list (liftReadPrec2 rp1 rl1 rp2 rl2)++-- | Lifting of the 'Show' class to binary type constructors.+--+-- @since 4.9.0.0+class (forall a. Show a => Show1 (f a)) => Show2 f where+    -- | 'showsPrec' function for an application of the type constructor+    -- based on 'showsPrec' and 'showList' functions for the argument types.+    --+    -- @since 4.9.0.0+    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.+    --+    -- @since 4.9.0.0+    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.+--+-- @since 4.9.0.0+showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS+showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList++-- Instances for Prelude type constructors++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+instance Read1 Maybe where+    liftReadPrec rp _ =+        parens (expectP (Ident "Nothing") *> pure Nothing)+        <|>+        readData (readUnaryWith rp "Just" Just)++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+instance Show1 Maybe where+    liftShowsPrec _ _ _ Nothing = showString "Nothing"+    liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x++-- | @since 4.9.0.0+instance Eq1 [] where+    liftEq _ [] [] = True+    liftEq _ [] (_:_) = False+    liftEq _ (_:_) [] = False+    liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys++-- | @since 4.9.0.0+instance Ord1 [] where+    liftCompare _ [] [] = EQ+    liftCompare _ [] (_:_) = LT+    liftCompare _ (_:_) [] = GT+    liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys++-- | @since 4.9.0.0+instance Read1 [] where+    liftReadPrec _ rl = rl+    liftReadListPrec  = liftReadListPrecDefault+    liftReadList      = liftReadListDefault++-- | @since 4.9.0.0+instance Show1 [] where+    liftShowsPrec _ sl _ = sl++-- | @since 4.10.0.0+instance Eq1 NonEmpty where+  liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs++-- | @since 4.10.0.0+instance Ord1 NonEmpty where+  liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs++-- | @since 4.10.0.0+instance Read1 NonEmpty where+  liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do+    (a, s'') <- rdP 6 s'+    (":|", s''') <- lex s''+    (as, s'''') <- rdL s'''+    return (a :| as, s'''')) s++-- | @since 4.10.0.0+instance Show1 NonEmpty where+  liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $+    shwP 6 a . showString " :| " . shwL as+++-- | @since 4.9.0.0+instance Eq2 (,) where+    liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2++-- | @since 4.9.0.0+instance Ord2 (,) where+    liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =+        comp1 x1 x2 `mappend` comp2 y1 y2++-- | @since 4.9.0.0+instance Read2 (,) where+    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do+        x <- rp1+        expectP (Punc ",")+        y <- rp2+        return (x,y)++    liftReadListPrec2 = liftReadListPrec2Default+    liftReadList2     = liftReadList2Default++-- | @since 4.9.0.0+instance Show2 (,) where+    liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =+        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'++-- | @since 4.15+instance Eq1 Solo where+  liftEq eq (MkSolo a) (MkSolo b) = a `eq` b++-- | @since 4.9.0.0+instance (Eq a) => Eq1 ((,) a) where+    liftEq = liftEq2 (==)++-- | @since 4.15+instance Ord1 Solo where+  liftCompare cmp (MkSolo a) (MkSolo b) = cmp a b++-- | @since 4.9.0.0+instance (Ord a) => Ord1 ((,) a) where+    liftCompare = liftCompare2 compare++-- | @since 4.15+instance Read1 Solo where+    liftReadPrec rp _ = readData (readUnaryWith rp "MkSolo" MkSolo)++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+instance (Read a) => Read1 ((,) a) where+    liftReadPrec = liftReadPrec2 readPrec readListPrec++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.15+instance Show1 Solo where+    liftShowsPrec sp _ d (MkSolo x) = showsUnaryWith sp "MkSolo" d x++-- | @since 4.9.0.0+instance (Show a) => Show1 ((,) a) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList+++-- | @since 4.16.0.0+--+-- >>> eq2 ('x', True, "str") ('x', True, "str")+-- True+--+instance Eq a => Eq2 ((,,) a) where+    liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) =+        u1 == v1 &&+        e1 x1 x2 && e2 y1 y2++-- | @since 4.16.0.0+--+-- >>> compare2 ('x', True, "aaa") ('x', True, "zzz")+-- LT+instance Ord a => Ord2 ((,,) a) where+    liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) =+        compare u1 v1 `mappend`+        comp1 x1 x2 `mappend` comp2 y1 y2++-- | @since 4.16.0.0+--+-- >>> readPrec_to_S readPrec2 0 "('x', True, 2)" :: [((Char, Bool, Int), String)]+-- [(('x',True,2),"")]+--+instance Read a => Read2 ((,,) a) where+    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do+        x1 <- readPrec+        expectP (Punc ",")+        y1 <- rp1+        expectP (Punc ",")+        y2 <- rp2+        return (x1,y1,y2)++    liftReadListPrec2 = liftReadListPrec2Default+    liftReadList2     = liftReadList2Default++-- | @since 4.16.0.0+--+-- >>> showsPrec2 0 ('x', True, 2 :: Int) ""+-- "('x',True,2)"+--+instance Show a => Show2 ((,,) a) where+    liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2)+        = showChar '(' . showsPrec 0 x1+        . showChar ',' . sp1 0 y1+        . showChar ',' . sp2 0 y2+        . showChar ')'++-- | @since 4.16.0.0+instance (Eq a, Eq b) => Eq1 ((,,) a b) where+    liftEq = liftEq2 (==)++-- | @since 4.16.0.0+instance (Ord a, Ord b) => Ord1 ((,,) a b) where+    liftCompare = liftCompare2 compare++-- | @since 4.16.0.0+instance (Read a, Read b) => Read1 ((,,) a b) where+    liftReadPrec = liftReadPrec2 readPrec readListPrec++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.16.0.0+instance (Show a, Show b) => Show1 ((,,) a b) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList+++-- | @since 4.16.0.0+--+-- >>> eq2 ('x', True, "str", 2) ('x', True, "str", 2 :: Int)+-- True+--+instance (Eq a, Eq b) => Eq2 ((,,,) a b) where+    liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) =+        u1 == v1 &&+        u2 == v2 &&+        e1 x1 x2 && e2 y1 y2++-- | @since 4.16.0.0+--+-- >>> compare2 ('x', True, "str", 2) ('x', True, "str", 3 :: Int)+-- LT+--+instance (Ord a, Ord b) => Ord2 ((,,,) a b) where+    liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) =+        compare u1 v1 `mappend`+        compare u2 v2 `mappend`+        comp1 x1 x2 `mappend` comp2 y1 y2++-- | @since 4.16.0.0+--+-- >>> readPrec_to_S readPrec2 0 "('x', True, 2, 4.5)" :: [((Char, Bool, Int, Double), String)]+-- [(('x',True,2,4.5),"")]+--+instance (Read a, Read b) => Read2 ((,,,) a b) where+    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do+        x1 <- readPrec+        expectP (Punc ",")+        x2 <- readPrec+        expectP (Punc ",")+        y1 <- rp1+        expectP (Punc ",")+        y2 <- rp2+        return (x1,x2,y1,y2)++    liftReadListPrec2 = liftReadListPrec2Default+    liftReadList2     = liftReadList2Default++-- | @since 4.16.0.0+--+-- >>> showsPrec2 0 ('x', True, 2 :: Int, 4.5 :: Double) ""+-- "('x',True,2,4.5)"+--+instance (Show a, Show b) => Show2 ((,,,) a b) where+    liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2)+        = showChar '(' . showsPrec 0 x1+        . showChar ',' . showsPrec 0 x2+        . showChar ',' . sp1 0 y1+        . showChar ',' . sp2 0 y2+        . showChar ')'++-- | @since 4.16.0.0+instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where+    liftEq = liftEq2 (==)++-- | @since 4.16.0.0+instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where+    liftCompare = liftCompare2 compare++-- | @since 4.16.0.0+instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where+    liftReadPrec = liftReadPrec2 readPrec readListPrec++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.16.0.0+instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++-- | @since 4.17.0.0+instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where+  liftEq :: (a1 -> a2 -> Bool) -> (Generically1 f a1 -> Generically1 f a2 -> Bool)+  liftEq (===) (Generically1 as1) (Generically1 as2) = liftEq (===) (from1 as1) (from1 as2)++-- | @since 4.17.0.0+instance (Generic1 f, Ord1 (Rep1 f)) => Ord1 (Generically1 f) where+  liftCompare :: (a1 -> a2 -> Ordering) -> (Generically1 f a1 -> Generically1 f a2 -> Ordering)+  liftCompare cmp (Generically1 as1) (Generically1 as2) = liftCompare cmp (from1 as1) (from1 as2)++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+instance Read2 Either where+    liftReadPrec2 rp1 _ rp2 _ = readData $+         readUnaryWith rp1 "Left" Left <|>+         readUnaryWith rp2 "Right" Right++    liftReadListPrec2 = liftReadListPrec2Default+    liftReadList2     = liftReadList2Default++-- | @since 4.9.0.0+instance Show2 Either where+    liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x+    liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x++-- | @since 4.9.0.0+instance (Eq a) => Eq1 (Either a) where+    liftEq = liftEq2 (==)++-- | @since 4.9.0.0+instance (Ord a) => Ord1 (Either a) where+    liftCompare = liftCompare2 compare++-- | @since 4.9.0.0+instance (Read a) => Read1 (Either a) where+    liftReadPrec = liftReadPrec2 readPrec readListPrec++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+instance (Show a) => Show1 (Either a) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++-- Instances for other functors defined in the base package++-- | @since 4.9.0.0+instance Eq1 Identity where+    liftEq eq (Identity x) (Identity y) = eq x y++-- | @since 4.9.0.0+instance Ord1 Identity where+    liftCompare comp (Identity x) (Identity y) = comp x y++-- | @since 4.9.0.0+instance Read1 Identity where+    liftReadPrec rp _ = readData $+         readUnaryWith rp "Identity" Identity++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+instance Show1 Identity where+    liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x++-- | @since 4.9.0.0+instance Eq2 Const where+    liftEq2 eq _ (Const x) (Const y) = eq x y++-- | @since 4.9.0.0+instance Ord2 Const where+    liftCompare2 comp _ (Const x) (Const y) = comp x y++-- | @since 4.9.0.0+instance Read2 Const where+    liftReadPrec2 rp _ _ _ = readData $+         readUnaryWith rp "Const" Const++    liftReadListPrec2 = liftReadListPrec2Default+    liftReadList2     = liftReadList2Default++-- | @since 4.9.0.0+instance Show2 Const where+    liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x++-- | @since 4.9.0.0+instance (Eq a) => Eq1 (Const a) where+    liftEq = liftEq2 (==)+-- | @since 4.9.0.0+instance (Ord a) => Ord1 (Const a) where+    liftCompare = liftCompare2 compare+-- | @since 4.9.0.0+instance (Read a) => Read1 (Const a) where+    liftReadPrec = liftReadPrec2 readPrec readListPrec++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault+-- | @since 4.9.0.0+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+  liftReadPrec _ _ = parens (expectP (Ident "Proxy") *> pure Proxy)++  liftReadListPrec = liftReadListPrecDefault+  liftReadList     = liftReadListDefault++-- | @since 4.12.0.0+instance Eq1 Down where+    liftEq eq (Down x) (Down y) = eq x y++-- | @since 4.12.0.0+instance Ord1 Down where+    liftCompare comp (Down x) (Down y) = case comp x y of+        LT -> GT+        EQ -> EQ+        GT -> LT++-- | @since 4.12.0.0+instance Read1 Down where+    liftReadsPrec rp _ = readsData $+         readsUnaryWith rp "Down" Down++-- | @since 4.12.0.0+instance Show1 Down where+    liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x++-- | @since 4.16.0.0+--+-- >>> eq1 (1 :+ 2) (1 :+ 2)+-- True+--+-- >>> eq1 (1 :+ 2) (1 :+ 3)+-- False+--+instance Eq1 Complex where+    liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v++-- | @since 4.16.0.0+--+-- >>> readPrec_to_S readPrec1 0 "(2 % 3) :+ (3 % 4)" :: [(Complex Rational, String)]+-- [(2 % 3 :+ 3 % 4,"")]+--+instance Read1 Complex where+    liftReadPrec rp _  = parens $ prec complexPrec $ do+        x <- step rp+        expectP (Symbol ":+")+        y <- step rp+        return (x :+ y)+      where+        complexPrec = 6++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.16.0.0+--+-- >>> showsPrec1 0 (2 :+ 3) ""+-- "2 :+ 3"+--+instance Show1 Complex where+    liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $+        sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y+      where+        complexPrec = 6++-- 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.+--+-- @since 4.9.0.0+readsData :: (String -> ReadS a) -> Int -> ReadS a+readsData reader d =+    readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]++-- | @'readData' p@ 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 'readUnaryWith' and 'readBinaryWith', and combined with+-- '(<|>)' from the 'Alternative' class.+--+-- @since 4.10.0.0+readData :: ReadPrec a -> ReadPrec a+readData reader = parens $ prec 10 reader++-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor+-- and then parses its argument using @rp@.+--+-- @since 4.9.0.0+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]++-- | @'readUnaryWith' rp n c'@ matches the name of a unary data constructor+-- and then parses its argument using @rp@.+--+-- @since 4.10.0.0+readUnaryWith :: ReadPrec a -> String -> (a -> t) -> ReadPrec t+readUnaryWith rp name cons = do+    expectP $ Ident name+    x <- step rp+    return $ cons x++-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary+-- data constructor and then parses its arguments using @rp1@ and @rp2@+-- respectively.+--+-- @since 4.9.0.0+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]++-- | @'readBinaryWith' rp1 rp2 n c'@ matches the name of a binary+-- data constructor and then parses its arguments using @rp1@ and @rp2@+-- respectively.+--+-- @since 4.10.0.0+readBinaryWith :: ReadPrec a -> ReadPrec b ->+    String -> (a -> b -> t) -> ReadPrec t+readBinaryWith rp1 rp2 name cons = do+    expectP $ Ident name+    x <- step rp1+    y <- step rp2+    return $ cons x y++-- | @'showsUnaryWith' sp n d x@ produces the string representation of a+-- unary data constructor with name @n@ and argument @x@, in precedence+-- context @d@.+--+-- @since 4.9.0.0+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@.+--+-- @since 4.9.0.0+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'.+--+-- @since 4.9.0.0+{-# 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'.+--+-- @since 4.9.0.0+{-# 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'.+--+-- @since 4.9.0.0+{-# 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@.+--+-- @since 4.9.0.0+{-# 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@.+--+-- @since 4.9.0.0+{-# 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@.+--+-- @since 4.9.0.0+{-# 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+>     liftReadPrec rp rl = readData $+>         readUnaryWith rp "Zero" Zero <|>+>         readUnaryWith (liftReadPrec rp rl) "One" One <|>+>         readBinaryWith rp (liftReadPrec rp rl) "Two" Two+>     liftReadListPrec = liftReadListPrecDefault++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++-}++-- | @since base-4.21.0.0+instance Eq1 V1 where+  liftEq _ = \_ _ -> True++-- | @since base-4.21.0.0+instance Ord1 V1 where+  liftCompare _ = \_ _ -> EQ++-- | @since base-4.21.0.0+instance Show1 V1 where+  liftShowsPrec _ _ _ = \_ -> showString "V1"++-- | @since base-4.21.0.0+instance Read1 V1 where+  liftReadsPrec _ _ = readPrec_to_S pfail+  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance Eq1 U1 where+  liftEq _ = \_ _ -> True++-- | @since base-4.21.0.0+instance Ord1 U1 where+  liftCompare _ = \_ _ -> EQ++-- | @since base-4.21.0.0+instance Show1 U1 where+  liftShowsPrec _ _ _ = \U1 -> showString "U1"++-- | @since base-4.21.0.0+instance Read1 U1 where+  liftReadPrec _ _ =+    parens (expectP (Ident "U1") *> pure U1)++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance Eq1 Par1 where+  liftEq eq = \(Par1 a) (Par1 a') -> eq a a'++-- | @since base-4.21.0.0+instance Ord1 Par1 where+  liftCompare cmp = \(Par1 a) (Par1 a') -> cmp a a'++-- | @since base-4.21.0.0+instance Show1 Par1 where+  liftShowsPrec sp _ d = \(Par1 { unPar1 = a }) ->+    showsSingleFieldRecordWith sp "Par1" "unPar1" d a++-- | @since base-4.21.0.0+instance Read1 Par1 where+  liftReadPrec rp _ =+    readsSingleFieldRecordWith rp "Par1" "unPar1" Par1++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance Eq1 f => Eq1 (Rec1 f) where+  liftEq eq = \(Rec1 a) (Rec1 a') -> liftEq eq a a'++-- | @since base-4.21.0.0+instance Ord1 f => Ord1 (Rec1 f) where+  liftCompare cmp = \(Rec1 a) (Rec1 a') -> liftCompare cmp a a'++-- | @since base-4.21.0.0+instance Show1 f => Show1 (Rec1 f) where+  liftShowsPrec sp sl d = \(Rec1 { unRec1 = a }) ->+    showsSingleFieldRecordWith (liftShowsPrec sp sl) "Rec1" "unRec1" d a++-- | @since base-4.21.0.0+instance Read1 f => Read1 (Rec1 f) where+  liftReadPrec rp rl =+    readsSingleFieldRecordWith (liftReadPrec rp rl) "Rec1" "unRec1" Rec1++  liftReadListPrec   = liftReadListPrecDefault+  liftReadList       = liftReadListDefault++-- | @since base-4.21.0.0+instance Eq c => Eq1 (K1 i c) where+  liftEq _ = \(K1 a) (K1 a') -> a == a'++-- | @since base-4.21.0.0+instance Ord c => Ord1 (K1 i c) where+  liftCompare _ = \(K1 a) (K1 a') -> compare a a'++-- | @since base-4.21.0.0+instance Show c => Show1 (K1 i c) where+  liftShowsPrec _ _ d = \(K1 { unK1 = a }) ->+    showsSingleFieldRecordWith showsPrec "K1" "unK1" d a++-- | @since base-4.21.0.0+instance Read c => Read1 (K1 i c) where+  liftReadPrec _ _ = readData $+    readsSingleFieldRecordWith readPrec "K1" "unK1" K1++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance Eq1 f => Eq1 (M1 i c f) where+  liftEq eq = \(M1 a) (M1 a') -> liftEq eq a a'++-- | @since base-4.21.0.0+instance Ord1 f => Ord1 (M1 i c f) where+  liftCompare cmp = \(M1 a) (M1 a') -> liftCompare cmp a a'++-- | @since base-4.21.0.0+instance Show1 f => Show1 (M1 i c f) where+  liftShowsPrec sp sl d = \(M1 { unM1 = a }) ->+    showsSingleFieldRecordWith (liftShowsPrec sp sl) "M1" "unM1" d a++-- | @since base-4.21.0.0+instance Read1 f => Read1 (M1 i c f) where+  liftReadPrec rp rl = readData $+    readsSingleFieldRecordWith (liftReadPrec rp rl) "M1" "unM1" M1++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance (Eq1 f, Eq1 g) => Eq1 (f :+: g) where+  liftEq eq = \lhs rhs -> case (lhs, rhs) of+    (L1 a, L1 a') -> liftEq eq a a'+    (R1 b, R1 b') -> liftEq eq b b'+    _           -> False++-- | @since base-4.21.0.0+instance (Ord1 f, Ord1 g) => Ord1 (f :+: g) where+  liftCompare cmp = \lhs rhs -> case (lhs, rhs) of+    (L1 _, R1 _)  -> LT+    (R1 _, L1 _)  -> GT+    (L1 a, L1 a') -> liftCompare cmp a a'+    (R1 b, R1 b') -> liftCompare cmp b b'++-- | @since base-4.21.0.0+instance (Show1 f, Show1 g) => Show1 (f :+: g) where+  liftShowsPrec sp sl d = \x -> case x of+    L1 a -> showsUnaryWith (liftShowsPrec sp sl) "L1" d a+    R1 b -> showsUnaryWith (liftShowsPrec sp sl) "R1" d b++-- | @since base-4.21.0.0+instance (Read1 f, Read1 g) => Read1 (f :+: g) where+  liftReadPrec rp rl = readData $+    readUnaryWith (liftReadPrec rp rl) "L1" L1 <|>+    readUnaryWith (liftReadPrec rp rl) "R1" R1++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where+  liftEq eq = \(f :*: g) (f' :*: g') -> liftEq eq f f' && liftEq eq g g'++-- | @since base-4.21.0.0+instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where+  liftCompare cmp = \(f :*: g) (f' :*: g') -> liftCompare cmp f f' <> liftCompare cmp g g'++-- | @since base-4.21.0.0+instance (Show1 f, Show1 g) => Show1 (f :*: g) where+  liftShowsPrec sp sl d = \(a :*: b) ->+    showsBinaryOpWith+      (liftShowsPrec sp sl)+      (liftShowsPrec sp sl)+      7+      ":*:"+      d+      a+      b++-- | @since base-4.21.0.0+instance (Read1 f, Read1 g) => Read1 (f :*: g) where+  liftReadPrec rp rl = parens $ prec 6 $+    readBinaryOpWith (liftReadPrec rp rl) (liftReadPrec rp rl) ":*:" (:*:)++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where+  liftEq eq = \(Comp1 a) (Comp1 a') -> liftEq (liftEq eq) a a'++-- | @since base-4.21.0.0+instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where+  liftCompare cmp = \(Comp1 a) (Comp1 a') -> liftCompare (liftCompare cmp) a a'++-- | @since base-4.21.0.0+instance (Show1 f, Show1 g) => Show1 (f :.: g) where+  liftShowsPrec sp sl d = \(Comp1 { unComp1 = a }) ->+    showsSingleFieldRecordWith+      (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl))+      "Comp1"+      "unComp1"+      d+      a++-- | @since base-4.21.0.0+instance (Read1 f, Read1 g) => Read1 (f :.: g) where+  liftReadPrec rp rl = readData $+    readsSingleFieldRecordWith+      (liftReadPrec (liftReadPrec rp rl) (liftReadListPrec rp rl))+      "Comp1"+      "unComp1"+      Comp1++  liftReadListPrec  = liftReadListPrecDefault+  liftReadList      = liftReadListDefault++-- | @since base-4.21.0.0+instance Eq1 UAddr where+  -- NB cannot use eqAddr# because its module isn't safe+  liftEq _ = \(UAddr a) (UAddr b) -> UAddr a == UAddr b++-- | @since base-4.21.0.0+instance Ord1 UAddr where+  liftCompare _ = \(UAddr a) (UAddr b) -> compare (UAddr a) (UAddr b)++-- | @since base-4.21.0.0+instance Show1 UAddr where+  liftShowsPrec _ _ = showsPrec++-- NB no Read1 for URec (Ptr ()) because there's no Read for Ptr.++-- | @since base-4.21.0.0+instance Eq1 UChar where+  liftEq _ = \(UChar a) (UChar b) -> UChar a == UChar b++-- | @since base-4.21.0.0+instance Ord1 UChar where+  liftCompare _ = \(UChar a) (UChar b) -> compare (UChar a) (UChar b)++-- | @since base-4.21.0.0+instance Show1 UChar where+  liftShowsPrec _ _ = showsPrec++-- | @since base-4.21.0.0+instance Eq1 UDouble where+  liftEq _ = \(UDouble a) (UDouble b) -> UDouble a == UDouble b++-- | @since base-4.21.0.0+instance Ord1 UDouble where+  liftCompare _ = \(UDouble a) (UDouble b) -> compare (UDouble a) (UDouble b)++-- | @since base-4.21.0.0+instance Show1 UDouble where+  liftShowsPrec _ _ = showsPrec++-- | @since base-4.21.0.0+instance Eq1 UFloat where+  liftEq _ = \(UFloat a) (UFloat b) -> UFloat a == UFloat b++-- | @since base-4.21.0.0+instance Ord1 UFloat where+  liftCompare _ = \(UFloat a) (UFloat b) -> compare (UFloat a) (UFloat b)++-- | @since base-4.21.0.0+instance Show1 UFloat where+  liftShowsPrec _ _ = showsPrec++-- | @since base-4.21.0.0+instance Eq1 UInt where+  liftEq _ = \(UInt a) (UInt b) -> UInt a == UInt b++-- | @since base-4.21.0.0+instance Ord1 UInt where+  liftCompare _ = \(UInt a) (UInt b) -> compare (UInt a) (UInt b)++-- | @since base-4.21.0.0+instance Show1 UInt where+  liftShowsPrec _ _ = showsPrec++-- | @since base-4.21.0.0+instance Eq1 UWord where+  liftEq _ = \(UWord a) (UWord b) -> UWord a == UWord b++-- | @since base-4.21.0.0+instance Ord1 UWord where+  liftCompare _ = \(UWord a) (UWord b) -> compare (UWord a) (UWord b)++-- | @since base-4.21.0.0+instance Show1 UWord where+  liftShowsPrec _ _ = showsPrec++showsSingleFieldRecordWith :: (Int -> a -> ShowS) -> String -> String -> Int -> a -> ShowS+showsSingleFieldRecordWith sp name field d x =+  showParen (d > appPrec) $+    showString name . showString " {" . showString field . showString " = " . sp 0 x . showChar '}'++readsSingleFieldRecordWith :: ReadPrec a -> String -> String -> (a -> t) -> ReadPrec t+readsSingleFieldRecordWith rp name field cons = parens $ prec 11 $ do+  expectP $ Ident name+  expectP $ Punc "{"+  x <- readField field $ reset rp+  expectP $ Punc "}"+  pure $ cons x++showsBinaryOpWith+  :: (Int -> a -> ShowS)+  -> (Int -> b -> ShowS)+  -> Int+  -> String+  -> Int+  -> a+  -> b+  -> ShowS+showsBinaryOpWith sp1 sp2 opPrec name d x y = showParen (d >= opPrec) $+  sp1 opPrec x . showChar ' ' . showString name . showChar ' ' . sp2 opPrec y++readBinaryOpWith+  :: ReadPrec a+  -> ReadPrec b+  -> String+  -> (a -> b -> t)+  -> ReadPrec t+readBinaryOpWith rp1 rp2 name cons =+  cons <$> step rp1 <* expectP (Symbol name) <*> step rp2
+ src/Data/Functor/Compose.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE StandaloneDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Compose+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Composition of functors.+--+-- @since 4.9.0.0+-----------------------------------------------------------------------------++module Data.Functor.Compose (+    Compose(..),+  ) where++import Data.Functor.Classes++import Control.Applicative+import GHC.Internal.Data.Coerce (coerce)+import GHC.Internal.Data.Data (Data)+import GHC.Internal.Data.Foldable (Foldable(..))+import GHC.Internal.Data.Monoid (Sum(..), All(..), Any(..), Product(..))+import GHC.Internal.Data.Type.Equality (TestEquality(..), (:~:)(..))+import GHC.Generics (Generic, Generic1)+import GHC.Internal.Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)+import Prelude++infixr 9 `Compose`++-- $setup+-- >>> import Prelude++-- | Right-to-left composition of functors.+-- The composition of applicative functors is always applicative,+-- but the composition of monads is not always a monad.+--+-- ==== __Examples__+--+-- >>> fmap (subtract 1) (Compose (Just [1, 2, 3]))+-- Compose (Just [0,1,2])+--+-- >>> Compose (Just [1, 2, 3]) <> Compose Nothing+-- Compose (Just [1,2,3])+--+-- >>> Compose (Just [(++ "World"), (++ "Haskell")]) <*> Compose (Just ["Hello, "])+-- Compose (Just ["Hello, World","Hello, Haskell"])+newtype Compose f g a = Compose { getCompose :: f (g a) }+  deriving ( Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           , Semigroup -- ^ @since 4.16.0.0+           , Monoid    -- ^ @since 4.16.0.0+           )++-- Instances of Prelude classes++-- | @since 4.18.0.0+deriving instance Eq (f (g a)) => Eq (Compose f g a)+-- | @since 4.18.0.0+deriving instance Ord (f (g a)) => Ord (Compose f g a)+-- | @since 4.18.0.0+instance Read (f (g a)) => Read (Compose f g a) where+    readPrec = liftReadPrecCompose readPrec++    readListPrec = readListPrecDefault+    readList     = readListDefault+-- | @since 4.18.0.0+instance Show (f (g a)) => Show (Compose f g a) where+    showsPrec = liftShowsPrecCompose showsPrec++-- Instances of lifted Prelude classes++-- | @since 4.9.0.0+instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where+    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y++-- | @since 4.9.0.0+instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where+    liftCompare comp (Compose x) (Compose y) =+        liftCompare (liftCompare comp) x y++-- | @since 4.9.0.0+instance (Read1 f, Read1 g) => Read1 (Compose f g) where+    liftReadPrec rp rl =+        liftReadPrecCompose (liftReadPrec rp' rl')+      where+        rp' = liftReadPrec     rp rl+        rl' = liftReadListPrec rp rl++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+instance (Show1 f, Show1 g) => Show1 (Compose f g) where+    liftShowsPrec sp sl =+        liftShowsPrecCompose (liftShowsPrec sp' sl')+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++-- The workhorse for Compose's Read and Read1 instances.+liftReadPrecCompose :: ReadPrec (f (g a)) -> ReadPrec (Compose f g a)+liftReadPrecCompose rp = readData $ readUnaryWith rp "Compose" Compose++-- The workhorse for Compose's Show and Show1 instances.+liftShowsPrecCompose :: (Int -> f (g a) -> ShowS) -> Int -> Compose f g a -> ShowS+liftShowsPrecCompose sp d (Compose x) = showsUnaryWith sp "Compose" d x++-- Functor instances++-- | @since 4.9.0.0+instance (Functor f, Functor g) => Functor (Compose f g) where+    fmap f (Compose x) = Compose (fmap (fmap f) x)+    a <$ (Compose x) = Compose (fmap (a <$) x)++-- | @since 4.9.0.0+instance (Foldable f, Foldable g) => Foldable (Compose f g) where+    fold (Compose t) = foldMap fold t+    foldMap f (Compose t) = foldMap (foldMap f) t+    foldMap' f (Compose t) = foldMap' (foldMap' f) t+    foldr f b (Compose fga) = foldr (\ga acc -> foldr f acc ga) b fga+    foldr' f b (Compose fga) = foldr' (\ga acc -> foldr' f acc ga) b fga+    foldl f b (Compose fga) = foldl (\acc ga -> foldl f acc ga) b fga+    foldl' f b (Compose fga) = foldl' (\acc ga -> foldl' f acc ga) b fga++    null (Compose t) = null t || getAll (foldMap (All . null) t)+    length (Compose t) = getSum (foldMap' (Sum . length) t)+    elem x (Compose t) = getAny (foldMap (Any . elem x) t)++    minimum (Compose fga) = minimum $ map minimum $ filter (not . null) $ toList fga+    maximum (Compose fga) = maximum $ map maximum $ filter (not . null) $ toList fga++    sum (Compose t) = getSum (foldMap' (Sum . sum) t)+    product (Compose t) = getProduct (foldMap' (Product . product) t)++-- | @since 4.9.0.0+instance (Traversable f, Traversable g) => Traversable (Compose f g) where+    traverse f (Compose t) = Compose <$> traverse (traverse f) t++-- | @since 4.9.0.0+instance (Applicative f, Applicative g) => Applicative (Compose f g) where+    pure x = Compose (pure (pure x))+    Compose f <*> Compose x = Compose (liftA2 (<*>) f x)+    liftA2 f (Compose x) (Compose y) =+      Compose (liftA2 (liftA2 f) x y)++-- | @since 4.9.0.0+instance (Alternative f, Applicative g) => Alternative (Compose f g) where+    empty = Compose empty+    (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a))+      :: forall a . Compose f g a -> Compose f g a -> Compose f g a+    some = coerce (fmap sequenceA . some :: f (g a) -> f (g [a]))+      :: forall a . Compose f g a -> Compose f g [a]+    many = coerce (fmap sequenceA . many :: f (g a) -> f (g [a]))+      :: forall a . Compose f g a -> Compose f g [a]++-- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.+--+-- @since 4.14.0.0+instance (TestEquality f) => TestEquality (Compose f g) where+  testEquality (Compose x) (Compose y) =+    case testEquality x y of -- :: Maybe (g x :~: g y)+      Just Refl -> Just Refl -- :: Maybe (x :~: y)+      Nothing   -> Nothing++-- | @since 4.19.0.0+deriving instance Enum (f (g a)) => Enum (Compose f g a)+-- | @since 4.19.0.0+deriving instance Bounded (f (g a)) => Bounded (Compose f g a)+-- | @since 4.19.0.0+deriving instance Num (f (g a)) => Num (Compose f g a)+-- | @since 4.19.0.0+deriving instance Real (f (g a)) => Real (Compose f g a)+-- | @since 4.19.0.0+deriving instance Integral (f (g a)) => Integral (Compose f g a)+-- | @since 4.20.0.0+deriving instance Fractional (f (g a)) => Fractional (Compose f g a)+-- | @since 4.20.0.0+deriving instance RealFrac (f (g a)) => RealFrac (Compose f g a)+-- | @since 4.20.0.0+deriving instance Floating (f (g a)) => Floating (Compose f g a)+-- | @since 4.20.0.0+deriving instance RealFloat (f (g a)) => RealFloat (Compose f g a)
+ src/Data/Functor/Const.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Safe #-}++-- |+--+-- 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   :  stable+-- Portability :  portable++module Data.Functor.Const+    (Const(..)+     ) where++import GHC.Internal.Data.Functor.Const
+ src/Data/Functor/Contravariant.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Contravariant+-- Copyright   :  (C) 2007-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,+-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'+-- the definition of 'Contravariant' for a given ADT is unambiguous.+--+-- @since 4.12.0.0+----------------------------------------------------------------------------++module Data.Functor.Contravariant (+  -- * Contravariant Functors+    Contravariant(..)+  , phantom++  -- * Operators+  , (>$<), (>$$<), ($<)++  -- * Predicates+  , Predicate(..)++  -- * Comparisons+  , Comparison(..)+  , defaultComparison++  -- * Equivalence Relations+  , Equivalence(..)+  , defaultEquivalence+  , comparisonEquivalence++  -- * Dual arrows+  , Op(..)+  ) where++import Control.Applicative+import GHC.Internal.Control.Category+import GHC.Internal.Data.Function (on)++import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.Compose++import GHC.Internal.Data.Monoid (Alt(..), All(..))+import GHC.Internal.Data.Proxy+import GHC.Generics++import Prelude hiding ((.), id)++-- | The class of contravariant functors.+--+-- Whereas in Haskell, one can think of a 'Functor' as containing or producing+-- values, a contravariant functor is a functor that can be thought of as+-- /consuming/ values.+--+-- As an example, consider the type of predicate functions  @a -> Bool@. One+-- such predicate might be @negative x = x < 0@, which+-- classifies integers as to whether they are negative. However, given this+-- predicate, we can re-use it in other situations, providing we have a way to+-- map values /to/ integers. For instance, we can use the @negative@ predicate+-- on a person's bank balance to work out if they are currently overdrawn:+--+-- @+-- newtype Predicate a = Predicate { getPredicate :: a -> Bool }+--+-- instance Contravariant Predicate where+--   contramap :: (a' -> a) -> (Predicate a -> Predicate a')+--   contramap f (Predicate p) = Predicate (p . f)+--                                          |   `- First, map the input...+--                                          `----- then apply the predicate.+--+-- overdrawn :: Predicate Person+-- overdrawn = contramap personBankBalance negative+-- @+--+-- Any instance should be subject to the following laws:+--+-- [Identity]    @'contramap' 'id'      = 'id'@+-- [Composition] @'contramap' (g . f) = 'contramap' f . 'contramap' g@+--+-- Note, that the second law follows from the free theorem of the type of+-- 'contramap' and the first law, so you need only check that the former+-- condition holds.++class Contravariant f where+  contramap :: (a' -> a) -> (f a -> f a')++  -- | Replace all locations in the output with the same value.+  -- The default definition is @'contramap' . 'const'@, but this may be+  -- overridden with a more efficient version.+  (>$) :: b -> f b -> f a+  (>$) = contramap . const++-- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor+-- in the laws of each of those classes, it can't actually use its argument in+-- any meaningful capacity.+--+-- This method is surprisingly useful. Where both instances exist and are+-- lawful we have the following laws:+--+-- @+-- 'fmap'      f ≡ 'phantom'+-- 'contramap' f ≡ 'phantom'+-- @+phantom :: (Functor f, Contravariant f) => f a -> f b+phantom x = () <$ x $< ()++infixl 4 >$, $<, >$<, >$$<++-- | This is '>$' with its arguments flipped.+($<) :: Contravariant f => f b -> b -> f a+($<) = flip (>$)++-- | This is an infix alias for 'contramap'.+(>$<) :: Contravariant f => (a -> b) -> (f b -> f a)+(>$<) = contramap++-- | This is an infix version of 'contramap' with the arguments flipped.+(>$$<) :: Contravariant f => f b -> (a -> b) -> f a+(>$$<) = flip contramap++deriving newtype instance Contravariant f => Contravariant (Alt f)+deriving newtype instance Contravariant f => Contravariant (Rec1 f)+deriving newtype instance Contravariant f => Contravariant (M1 i c f)++instance Contravariant V1 where+  contramap :: (a' -> a) -> (V1 a -> V1 a')+  contramap _ x = case x of++instance Contravariant U1 where+  contramap :: (a' -> a) -> (U1 a -> U1 a')+  contramap _ _ = U1++instance Contravariant (K1 i c) where+  contramap :: (a' -> a) -> (K1 i c a -> K1 i c a')+  contramap _ (K1 c) = K1 c++instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where+  contramap :: (a' -> a) -> ((f :*: g) a -> (f :*: g) a')+  contramap f (xs :*: ys) = contramap f xs :*: contramap f ys++instance (Functor f, Contravariant g) => Contravariant (f :.: g) where+  contramap :: (a' -> a) -> ((f :.: g) a -> (f :.: g) a')+  contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)++instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where+  contramap :: (a' -> a) -> ((f :+: g) a -> (f :+: g) a')+  contramap f (L1 xs) = L1 (contramap f xs)+  contramap f (R1 ys) = R1 (contramap f ys)++instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where+  contramap :: (a' -> a) -> (Sum f g a -> Sum f g a')+  contramap f (InL xs) = InL (contramap f xs)+  contramap f (InR ys) = InR (contramap f ys)++instance (Contravariant f, Contravariant g)+      => Contravariant (Product f g) where+  contramap :: (a' -> a) -> (Product f g a -> Product f g a')+  contramap f (Pair a b) = Pair (contramap f a) (contramap f b)++instance Contravariant (Const a) where+  contramap :: (b' -> b) -> (Const a b -> Const a b')+  contramap _ (Const a) = Const a++instance (Functor f, Contravariant g) => Contravariant (Compose f g) where+  contramap :: (a' -> a) -> (Compose f g a -> Compose f g a')+  contramap f (Compose fga) = Compose (fmap (contramap f) fga)++instance Contravariant Proxy where+  contramap :: (a' -> a) -> (Proxy a -> Proxy a')+  contramap _ _ = Proxy++newtype Predicate a = Predicate { getPredicate :: a -> Bool }+  deriving+    ( -- | @('<>')@ on predicates uses logical conjunction @('&&')@ on+      -- the results. Without newtypes this equals @'liftA2' (&&)@.+      --+      -- @+      -- (<>) :: Predicate a -> Predicate a -> Predicate a+      -- Predicate pred <> Predicate pred' = Predicate \a ->+      --   pred a && pred' a+      -- @+      Semigroup+    , -- | @'mempty'@ on predicates always returns @True@. Without+      -- newtypes this equals @'pure' True@.+      --+      -- @+      -- mempty :: Predicate a+      -- mempty = \_ -> True+      -- @+      Monoid+    )+  via a -> All++  deriving+    ( -- | A 'Predicate' is a 'Contravariant' 'Functor', because+      -- 'contramap' can apply its function argument to the input of+      -- the predicate.+      --+      -- Without newtypes @'contramap' f@ equals precomposing with @f@+      -- (= @(. f)@).+      --+      -- @+      -- contramap :: (a' -> a) -> (Predicate a -> Predicate a')+      -- contramap f (Predicate g) = Predicate (g . f)+      -- @+      Contravariant+    )+  via Op Bool++-- | Defines a total ordering on a type as per 'compare'.+--+-- This condition is not checked by the types. You must ensure that the+-- supplied values are valid total orderings yourself.+newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }+  deriving+  newtype+    ( -- | @('<>')@ on comparisons combines results with @('<>')+      -- \@Ordering@. Without newtypes this equals @'liftA2' ('liftA2'+      -- ('<>'))@.+      --+      -- @+      -- (<>) :: Comparison a -> Comparison a -> Comparison a+      -- Comparison cmp <> Comparison cmp' = Comparison \a a' ->+      --   cmp a a' <> cmp a a'+      -- @+      Semigroup+    , -- | @'mempty'@ on comparisons always returns @EQ@. Without+      -- newtypes this equals @'pure' ('pure' EQ)@.+      --+      -- @+      -- mempty :: Comparison a+      -- mempty = Comparison \_ _ -> EQ+      -- @+      Monoid+    )++-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to each input of the comparison function.+instance Contravariant Comparison where+  contramap :: (a' -> a) -> (Comparison a -> Comparison a')+  contramap f (Comparison g) = Comparison (on g f)++-- | Compare using 'compare'.+defaultComparison :: Ord a => Comparison a+defaultComparison = Comparison compare++-- | This data type represents an equivalence relation.+--+-- Equivalence relations are expected to satisfy three laws:+--+-- [Reflexivity]:  @'getEquivalence' f a a = True@+-- [Symmetry]:     @'getEquivalence' f a b = 'getEquivalence' f b a@+-- [Transitivity]:+--    If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True'+--    then so is @'getEquivalence' f a c@.+--+-- The types alone do not enforce these laws, so you'll have to check them+-- yourself.+newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }+  deriving+    ( -- | @('<>')@ on equivalences uses logical conjunction @('&&')@+      -- on the results. Without newtypes this equals @'liftA2'+      -- ('liftA2' (&&))@.+      --+      -- @+      -- (<>) :: Equivalence a -> Equivalence a -> Equivalence a+      -- Equivalence equiv <> Equivalence equiv' = Equivalence \a b ->+      --   equiv a b && equiv' a b+      -- @+      Semigroup+    , -- | @'mempty'@ on equivalences always returns @True@. Without+      -- newtypes this equals @'pure' ('pure' True)@.+      --+      -- @+      -- mempty :: Equivalence a+      -- mempty = Equivalence \_ _ -> True+      -- @+      Monoid+    )+  via a -> a -> All++-- | Equivalence relations are 'Contravariant', because you can+-- apply the contramapped function to each input to the equivalence+-- relation.+instance Contravariant Equivalence where+  contramap :: (a' -> a) -> (Equivalence a -> Equivalence a')+  contramap f (Equivalence g) = Equivalence (on g f)++-- | Check for equivalence with '=='.+--+-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.+defaultEquivalence :: Eq a => Equivalence a+defaultEquivalence = Equivalence (==)++comparisonEquivalence :: Comparison a -> Equivalence a+comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ++-- | Dual function arrows.+newtype Op a b = Op { getOp :: b -> a }+  deriving+  newtype+    ( -- | @('<>') \@(Op a b)@ without newtypes is @('<>') \@(b->a)@ =+      -- @liftA2 ('<>')@. This lifts the 'Semigroup' operation+      -- @('<>')@ over the output of @a@.+      --+      -- @+      -- (<>) :: Op a b -> Op a b -> Op a b+      -- Op f <> Op g = Op \a -> f a <> g a+      -- @+      Semigroup+    , -- | @'mempty' \@(Op a b)@ without newtypes is @mempty \@(b->a)@+      -- = @\_ -> mempty@.+      --+      -- @+      -- mempty :: Op a b+      -- mempty = Op \_ -> mempty+      -- @+      Monoid+    )++instance Category Op where+  id :: Op a a+  id = Op id++  (.) :: Op b c -> Op a b -> Op a c+  Op f . Op g = Op (g . f)++instance Contravariant (Op a) where+  contramap :: (b' -> b) -> (Op a b -> Op a b')+  contramap f g = Op (getOp g . f)++instance Num a => Num (Op a b) where+  Op f + Op g = Op $ \a -> f a + g a+  Op f * Op g = Op $ \a -> f a * g a+  Op f - Op g = Op $ \a -> f a - g a+  abs (Op f) = Op $ abs . f+  signum (Op f) = Op $ signum . f+  fromInteger = Op . const . fromInteger++instance Fractional a => Fractional (Op a b) where+  Op f / Op g = Op $ \a -> f a / g a+  recip (Op f) = Op $ recip . f+  fromRational = Op . const . fromRational++instance Floating a => Floating (Op a b) where+  pi = Op $ const pi+  exp (Op f) = Op $ exp . f+  sqrt (Op f) = Op $ sqrt . f+  log (Op f) = Op $ log . f+  sin (Op f) = Op $ sin . f+  tan (Op f) = Op $ tan . f+  cos (Op f) = Op $ cos . f+  asin (Op f) = Op $ asin . f+  atan (Op f) = Op $ atan . f+  acos (Op f) = Op $ acos . f+  sinh (Op f) = Op $ sinh . f+  tanh (Op f) = Op $ tanh . f+  cosh (Op f) = Op $ cosh . f+  asinh (Op f) = Op $ asinh . f+  atanh (Op f) = Op $ atanh . f+  acosh (Op f) = Op $ acosh . f+  Op f ** Op g = Op $ \a -> f a ** g a+  logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)
+ src/Data/Functor/Identity.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Functor.Identity+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  ross@soi.city.ac.uk+-- Stability   :  stable+-- Portability :  portable+--+-- The identity functor and monad.+--+-- This trivial type constructor serves two purposes:+--+-- * It can be used with functions parameterized by functor or monad classes.+--+-- * It can be used as a base monad to which a series of monad+--   transformers may be applied to construct a composite monad.+--   Most monad transformer modules include the special case of+--   applying the transformer to 'Identity'.  For example, @State s@+--   is an abbreviation for @StateT s 'Identity'@.+--+-- @since 4.8.0.0++module Data.Functor.Identity+    (Identity(..)+     ) where++import GHC.Internal.Data.Functor.Identity
+ src/Data/Functor/Product.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Product+-- Copyright   :  (c) Ross Paterson 2010+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Products, lifted to functors.+--+-- @since 4.9.0.0+-----------------------------------------------------------------------------++module Data.Functor.Product (+    Product(..),+  ) where++import Control.Applicative+import GHC.Internal.Control.Monad (MonadPlus(..))+import GHC.Internal.Control.Monad.Fix (MonadFix(..))+import Control.Monad.Zip (MonadZip(mzipWith))+import GHC.Internal.Data.Data (Data)+import Data.Functor.Classes+import GHC.Generics (Generic, Generic1)+import Prelude++-- $setup+-- >>> import Prelude++-- | Lifted product of functors.+--+-- ==== __Examples__+--+-- >>> fmap (+1) (Pair [1, 2, 3] (Just 0))+-- Pair [2,3,4] (Just 1)+--+-- >>> Pair "Hello, " (Left 'x') <> Pair "World" (Right 'y')+-- Pair "Hello, World" (Right 'y')+data Product f g a = Pair (f a) (g a)+  deriving ( Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.18.0.0+deriving instance (Eq (f a), Eq (g a)) => Eq (Product f g a)+-- | @since 4.18.0.0+deriving instance (Ord (f a), Ord (g a)) => Ord (Product f g a)+-- | @since 4.18.0.0+deriving instance (Read (f a), Read (g a)) => Read (Product f g a)+-- | @since 4.18.0.0+deriving instance (Show (f a), Show (g a)) => Show (Product f g a)++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+instance (Read1 f, Read1 g) => Read1 (Product f g) where+    liftReadPrec rp rl = readData $+        readBinaryWith (liftReadPrec rp rl) (liftReadPrec rp rl) "Pair" Pair++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+instance (Functor f, Functor g) => Functor (Product f g) where+    fmap f (Pair x y) = Pair (fmap f x) (fmap f y)+    a <$ (Pair x y) = Pair (a <$ x) (a <$ y)++-- | @since 4.9.0.0+instance (Foldable f, Foldable g) => Foldable (Product f g) where+    foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y++-- | @since 4.9.0.0+instance (Traversable f, Traversable g) => Traversable (Product f g) where+    traverse f (Pair x y) = liftA2 Pair (traverse f x) (traverse f y)++-- | @since 4.9.0.0+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)+    liftA2 f (Pair a b) (Pair x y) = Pair (liftA2 f a x) (liftA2 f b y)++-- | @since 4.9.0.0+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)++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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)++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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)++-- | @since 4.16.0.0+instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Product f g a) where+    Pair x1 y1 <> Pair x2 y2 = Pair (x1 <> x2) (y1 <> y2)++-- | @since 4.16.0.0+instance (Monoid (f a), Monoid (g a)) => Monoid (Product f g a) where+    mempty = Pair mempty mempty
+ src/Data/Functor/Sum.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE StandaloneDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Functor.Sum+-- Copyright   :  (c) Ross Paterson 2014+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Sums, lifted to functors.+--+-- @since 4.9.0.0+-----------------------------------------------------------------------------++module Data.Functor.Sum (+    Sum(..),+  ) where++import Control.Applicative ((<|>))+import GHC.Internal.Data.Data (Data)+import Data.Functor.Classes+import GHC.Generics (Generic, Generic1)+import Prelude++-- $setup+-- >>> import Prelude++-- | Lifted sum of functors.+--+-- ==== __Examples__+--+-- >>> fmap (+1) (InL (Just 1))  :: Sum Maybe [] Int+-- InL (Just 2)+--+-- >>> fmap (+1) (InR [1, 2, 3]) :: Sum Maybe [] Int+-- InR [2,3,4]+data Sum f g a = InL (f a) | InR (g a)+  deriving ( Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.18.0.0+deriving instance (Eq (f a), Eq (g a)) => Eq (Sum f g a)+-- | @since 4.18.0.0+deriving instance (Ord (f a), Ord (g a)) => Ord (Sum f g a)+-- | @since 4.18.0.0+deriving instance (Read (f a), Read (g a)) => Read (Sum f g a)+-- | @since 4.18.0.0+deriving instance (Show (f a), Show (g a)) => Show (Sum f g a)++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+instance (Read1 f, Read1 g) => Read1 (Sum f g) where+    liftReadPrec rp rl = readData $+        readUnaryWith (liftReadPrec rp rl) "InL" InL <|>+        readUnaryWith (liftReadPrec rp rl) "InR" InR++    liftReadListPrec = liftReadListPrecDefault+    liftReadList     = liftReadListDefault++-- | @since 4.9.0.0+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++-- | @since 4.9.0.0+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)++    a <$ (InL x) = InL (a <$ x)+    a <$ (InR y) = InR (a <$ y)++-- | @since 4.9.0.0+instance (Foldable f, Foldable g) => Foldable (Sum f g) where+    foldMap f (InL x) = foldMap f x+    foldMap f (InR y) = foldMap f y++-- | @since 4.9.0.0+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
+ src/Data/IORef.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.IORef+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Mutable references in the IO monad.+--++module Data.IORef+    (-- *  IORefs+     IORef,+     newIORef,+     readIORef,+     writeIORef,+     modifyIORef,+     modifyIORef',+     atomicModifyIORef,+     atomicModifyIORef',+     atomicWriteIORef,+     mkWeakIORef,+     -- **  Memory Model+     -- $memmodel+     ) where++import GHC.Internal.Data.IORef++{- $memmodel+  #memmodel#++  Most modern CPU achitectures (e.g. x86/64, ARM) have a memory model which allows+  threads to reorder reads with earlier writes to different locations,+  e.g. see <https://www.intel.com/content/www/us/en/developer/articles/technical/intel-sdm.html the x86/64 architecture manual>,+  8.2.3.4 Loads May Be Reordered with Earlier Stores to Different Locations.++  Because of that, in a concurrent program, 'IORef' operations may appear out-of-order+  to another thread. In the following example:++  > import GHC.Internal.Data.IORef+  > import GHC.Internal.Control.Monad (unless)+  > import Control.Concurrent (forkIO, threadDelay)+  >+  > maybePrint :: IORef Bool -> IORef Bool -> IO ()+  > maybePrint myRef yourRef = do+  >   writeIORef myRef True+  >   yourVal <- readIORef yourRef+  >   unless yourVal $ putStrLn "critical section"+  >+  > main :: IO ()+  > main = do+  >   r1 <- newIORef False+  >   r2 <- newIORef False+  >   forkIO $ maybePrint r1 r2+  >   forkIO $ maybePrint r2 r1+  >   threadDelay 1000000++  it is possible that the string @"critical section"@ is printed+  twice, even though there is no interleaving of the operations of the+  two threads that allows that outcome.  The memory model of x86/64+  allows 'readIORef' to happen before the earlier 'writeIORef'.++  The ARM memory order model is typically even weaker than x86/64, allowing+  any reordering of reads and writes as long as they are independent+  from the point of view of the current thread.++  The implementation is required to ensure that reordering of memory+  operations cannot cause type-correct code to go wrong.  In+  particular, when inspecting the value read from an 'IORef', the+  memory writes that created that value must have occurred from the+  point of view of the current thread.++  'atomicWriteIORef', 'atomicModifyIORef' and 'atomicModifyIORef'' act+  as a barrier to reordering. Multiple calls to these functions+  occur in strict program order, never taking place ahead of any+  earlier (in program order) 'IORef' operations, or after any later+  'IORef' operations.++-}
+ src/Data/Int.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Int+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Signed integer types+--++module Data.Int+    (-- *  Signed integer types+     Int,+     Int8,+     Int16,+     Int32,+     Int64,+     -- *  Notes+     -- $notes+     ) where++import GHC.Internal.Int++{- $notes++* All arithmetic is performed modulo 2^n, where @n@ is the number of+  bits in the type.++* For coercing between any two integer types, use 'Prelude.fromIntegral',+  which is specialized for all the common cases so should be fast+  enough.  Coercing word types (see "Data.Word") to and from integer+  types preserves representation, not sign.++* The rules that hold for 'Prelude.Enum' instances over a+  bounded type such as 'Int' (see the section of the+  Haskell report dealing with arithmetic sequences) also hold for the+  'Prelude.Enum' instances over the various+  'Int' types defined here.++* Right and left shifts by amounts greater than or equal to the width+  of the type result in either zero or -1, depending on the sign of+  the value being shifted.  This is contrary to the behaviour in C,+  which is undefined; a common interpretation is to truncate the shift+  count to the width of the type, for example @1 \<\< 32+  == 1@ in some C implementations.+-}+
+ src/Data/Ix.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Ix+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The 'Ix' class is used to map a contiguous subrange of values in+-- type onto integers.  It is used primarily for array indexing+-- (see the array package).  'Ix' uses row-major order.+--++module Data.Ix+    (-- *  The 'Ix' class+     Ix(range, index, inRange, rangeSize),+     -- *  Deriving Instances of 'Ix'+     -- |  Derived instance declarations for the class 'Ix' are only possible+     -- for enumerations (i.e. datatypes having only nullary constructors)+     -- and single-constructor datatypes, including arbitrarily large tuples,+     -- whose constituent types are instances of 'Ix'.+     --+     -- * For an enumeration, the nullary constructors are assumed to be+     -- numbered left-to-right with the indices being 0 to n-1 inclusive. This+     -- is the same numbering defined by the 'Enum' class. For example, given+     -- the datatype:+     --+     -- >        data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet+     --+     -- we would have:+     --+     -- >        range   (Yellow,Blue)        ==  [Yellow,Green,Blue]+     -- >        index   (Yellow,Blue) Green  ==  1+     -- >        inRange (Yellow,Blue) Red    ==  False+     --+     -- * For single-constructor datatypes, the derived instance declarations+     -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report:+     -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>.+     ) where++import GHC.Internal.Data.Ix
+ src/Data/Kind.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Trustworthy #-}++-- |+--+-- Module      :  Data.Kind+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  not portable+--+-- Basic kinds+--+-- @since 4.9.0.0++module Data.Kind+    (Type,+     Constraint,+     FUN+     ) where++import GHC.Prim (FUN)+import GHC.Types (Type, Constraint)
+ src/Data/List.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.List+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Operations on lists.+--++module Data.List+    (List,+     -- *  Basic functions+     (++),+     head,+     last,+     tail,+     init,+     uncons,+     unsnoc,+     singleton,+     null,+     length,+     compareLength,+     -- *  List transformations+     map,+     reverse,+     intersperse,+     intercalate,+     transpose,+     subsequences,+     permutations,+     -- *  Reducing lists (folds)+     foldl,+     foldl',+     foldl1,+     foldl1',+     foldr,+     foldr1,+     -- **  Special folds+     concat,+     concatMap,+     and,+     or,+     any,+     all,+     sum,+     product,+     maximum,+     minimum,+     -- *  Building lists+     -- **  Scans+     scanl,+     scanl',+     scanl1,+     scanr,+     scanr1,+     -- **  Accumulating maps+     mapAccumL,+     mapAccumR,+     -- **  Infinite lists+     iterate,+     iterate',+     repeat,+     replicate,+     cycle,+     -- **  Unfolding+     unfoldr,+     -- *  Sublists+     -- **  Extracting sublists+     take,+     drop,+     splitAt,+     takeWhile,+     dropWhile,+     dropWhileEnd,+     span,+     break,+     stripPrefix,+     group,+     inits,+     inits1,+     tails,+     tails1,+     -- **  Predicates+     isPrefixOf,+     isSuffixOf,+     isInfixOf,+     isSubsequenceOf,+     -- *  Searching lists+     -- **  Searching by equality+     elem,+     notElem,+     lookup,+     -- **  Searching with a predicate+     find,+     filter,+     partition,+     -- *  Indexing lists+     -- |  These functions treat a list @xs@ as an indexed collection,+     -- with indices ranging from 0 to @'length' xs - 1@.+     (!?),+     (!!),+     elemIndex,+     elemIndices,+     findIndex,+     findIndices,+     -- *  Zipping and unzipping lists+     zip,+     zip3,+     zip4,+     zip5,+     zip6,+     zip7,+     zipWith,+     zipWith3,+     zipWith4,+     zipWith5,+     zipWith6,+     zipWith7,+     unzip,+     unzip3,+     unzip4,+     unzip5,+     unzip6,+     unzip7,+     -- *  Special lists+     -- **  Functions on strings+     lines,+     words,+     unlines,+     unwords,+     -- **  \"Set\" operations+     nub,+     delete,+     (\\),+     union,+     intersect,+     -- **  Ordered lists+     sort,+     sortOn,+     insert,+     -- *  Generalized functions+     -- **  The \"@By@\" operations+     -- |  By convention, overloaded functions have a non-overloaded+     -- counterpart whose name is suffixed with \`@By@\'.+     --+     -- It is often convenient to use these functions together with+     -- 'Data.Function.on', for instance @'sortBy' ('Prelude.compare'+     -- ``Data.Function.on`` 'Prelude.fst')@.++     -- ***  User-supplied equality (replacing an @Eq@ context)+     -- |  The predicate is assumed to define an equivalence.+     nubBy,+     deleteBy,+     deleteFirstsBy,+     unionBy,+     intersectBy,+     groupBy,+     -- ***  User-supplied comparison (replacing an @Ord@ context)+     -- |  The function is assumed to define a total ordering.+     sortBy,+     insertBy,+     maximumBy,+     minimumBy,+     -- **  The \"@generic@\" operations+     -- |  The prefix \`@generic@\' indicates an overloaded function that+     -- is a generalized version of a "Prelude" function.+     genericLength,+     genericTake,+     genericDrop,+     genericSplitAt,+     genericIndex,+     genericReplicate+     ) where++import GHC.Internal.Data.Bool (otherwise)+import GHC.Internal.Data.List+import GHC.Internal.Data.List.NonEmpty (NonEmpty(..))+import GHC.Internal.Data.Ord (Ordering(..), (<), (>))+import GHC.Internal.Int (Int)+import GHC.Internal.Num ((-))+import GHC.List (build)++inits1, tails1 :: [a] -> [NonEmpty a]++-- | The 'inits1' function returns all non-empty initial segments of the+-- argument, shortest first.+--+-- @since 4.21.0.0+--+-- ==== __Laziness__+--+-- Note that 'inits1' has the following strictness property:+-- @inits1 (xs ++ _|_) = inits1 xs ++ _|_@+--+-- In particular,+-- @inits1 _|_ = _|_@+--+-- ==== __Examples__+--+-- >>> inits1 "abc"+-- ['a' :| "",'a' :| "b",'a' :| "bc"]+--+-- >>> inits1 []+-- []+--+-- inits1 is productive on infinite lists:+--+-- >>> take 3 $ inits1 [1..]+-- [1 :| [],1 :| [2],1 :| [2,3]]+inits1 [] = []+inits1 (x : xs) = map (x :|) (inits xs)++-- | \(\mathcal{O}(n)\). The 'tails1' function returns all non-empty final+-- segments of the argument, longest first.+--+-- @since 4.21.0.0+--+-- ==== __Laziness__+--+-- Note that 'tails1' has the following strictness property:+-- @tails1 _|_ = _|_@+--+-- >>> tails1 undefined+-- *** Exception: Prelude.undefined+--+-- >>> drop 1 (tails1 [undefined, 1, 2])+-- [1 :| [2],2 :| []]+--+-- ==== __Examples__+--+-- >>> tails1 "abc"+-- ['a' :| "bc",'b' :| "c",'c' :| ""]+--+-- >>> tails1 [1, 2, 3]+-- [1 :| [2,3],2 :| [3],3 :| []]+--+-- >>> tails1 []+-- []+{-# INLINABLE tails1 #-}+tails1 lst = build (\c n ->+  let tails1Go [] = n+      tails1Go (x : xs) = (x :| xs) `c` tails1Go xs+  in tails1Go lst)++-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative+-- to 'compare' ('length' @xs@) @n@. Similarly, it's better+-- to write @compareLength xs 10 == LT@ instead of @length xs < 10@.+--+-- While 'length' would force and traverse+-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite),+-- 'compareLength' traverses at most @n@ elements to determine its result.+--+-- >>> compareLength [] 0+-- EQ+-- >>> compareLength [] 1+-- LT+-- >>> compareLength ['a'] 1+-- EQ+-- >>> compareLength ['a', 'b'] 1+-- GT+-- >>> compareLength [0..] 100+-- GT+-- >>> compareLength undefined (-1)+-- GT+-- >>> compareLength ('a' : undefined) 0+-- GT+--+-- @since 4.21.0.0+--+compareLength :: [a] -> Int -> Ordering+compareLength xs n+  | n < 0 = GT+  | otherwise = foldr+    (\_ f m -> if m > 0 then f (m - 1) else GT)+    (\m -> if m > 0 then LT else EQ)+    xs+    n
+ src/Data/List/NonEmpty.hs view
@@ -0,0 +1,616 @@+{-# 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+----------------------------------------------------------------------------++-- Function implementations in this module adhere to the following principle:+--+-- For every NonEmpty function that is different from a corresponding+-- List function only in the presence of NonEmpty in its type, both+-- the List and NonEmpty functions should have the same strictness+-- properties. Same applies to the class instances.++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+   , compareLength -- :: NonEmpty a -> Int -> Ordering+   , head        -- :: NonEmpty a -> a+   , tail        -- :: NonEmpty a -> [a]+   , last        -- :: NonEmpty a -> a+   , init        -- :: NonEmpty a -> [a]+   , singleton   -- :: a -> NonEmpty a+   , (<|), cons  -- :: a -> NonEmpty a -> NonEmpty a+   , uncons      -- :: NonEmpty a -> (a, Maybe (NonEmpty a))+   , unfoldr     -- :: (a -> (b, Maybe a)) -> a -> NonEmpty b+   , sort        -- :: Ord a => NonEmpty a -> NonEmpty a+   , sortOn      -- :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a+   , reverse     -- :: NonEmpty a -> NonEmpty a+   , inits       -- :: Foldable f => f a -> NonEmpty [a]+   , inits1      -- :: NonEmpty a -> NonEmpty (NonEmpty a)+   , tails       -- :: Foldable f => f a -> NonEmpty [a]+   , tails1      -- :: NonEmpty a -> NonEmpty (NonEmpty a)+   , append      -- :: NonEmpty a -> NonEmpty a -> NonEmpty a+   , appendList  -- :: NonEmpty a -> [a] -> NonEmpty a+   , prependList -- :: [a] -> NonEmpty 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   -- :: (a -> Bool) -> NonEmpty a -> [a]+   , dropWhile   -- :: (a -> Bool) -> NonEmpty a -> [a]+   , span        -- :: (a -> Bool) -> NonEmpty a -> ([a], [a])+   , break       -- :: (a -> Bool) -> 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  -- :: Ord b => (a -> b) -> [a] -> [NonEmpty a]+   , group1      -- :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a)+   , groupBy1    -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a)+   , groupWith1     -- :: Eq b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)+   , groupAllWith1  -- :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)+   , permutations   -- :: [a] -> NonEmpty [a]+   , permutations1  -- :: NonEmpty a -> NonEmpty (NonEmpty a)+   -- * Sublist predicates+   , isPrefixOf  -- :: Eq a => [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       -- :: Functor f => f (a,b) -> (f a, f b)+   -- * Converting to and from a list+   , fromList    -- :: [a] -> NonEmpty a+   , toList      -- :: NonEmpty a -> [a]+   , nonEmpty    -- :: [a] -> Maybe (NonEmpty a)+   , xor         -- :: NonEmpty Bool -> 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, (!!), Applicative(..))+import qualified Prelude++import           Control.Applicative (Applicative (..), Alternative (many))+import qualified Data.List                        as List+import           GHC.Internal.Data.Foldable       hiding (length, toList)+import qualified GHC.Internal.Data.Foldable       as Foldable+import           GHC.Internal.Data.Function       (on)+import           GHC.Internal.Data.Ord            (comparing)+import           GHC.Internal.Stack.Types     (HasCallStack)+import           GHC.Internal.Data.List.NonEmpty (NonEmpty (..), map, zip, zipWith)++infixr 5 <|++-- $setup+-- >>> import Prelude+-- >>> import qualified Data.List as List+-- >>> import Data.Ord (comparing)++-- | Number of elements in 'NonEmpty' list.+length :: NonEmpty a -> Int+length (_ :| xs) = 1 + Prelude.length xs++-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative+-- to 'compare' ('length' @xs@) @n@. Similarly, it's better+-- to write @compareLength xs 10 == LT@ instead of @length xs < 10@.+--+-- While 'length' would force and traverse+-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite),+-- 'compareLength' traverses at most @n@ elements to determine its result.+--+-- >>> compareLength ('a' :| []) 1+-- EQ+-- >>> compareLength ('a' :| ['b']) 3+-- LT+-- >>> compareLength (0 :| [1..]) 100+-- GT+-- >>> compareLength undefined 0+-- GT+-- >>> compareLength ('a' :| 'b' : undefined) 1+-- GT+--+-- @since 4.21.0.0+--+compareLength :: NonEmpty a -> Int -> Ordering+compareLength xs n+  | n < 1 = GT+  | otherwise = foldr+    (\_ f m -> if m > 0 then f (m - 1) else GT)+    (\m -> if m > 0 then LT else EQ)+    xs+    n++-- | 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+{-# DEPRECATED unfold "Use unfoldr" #-}+-- Deprecated in 8.2.1, remove in 8.4++-- | '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+-- 'GHC.Internal.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++-- | 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 :| []) = a+last (_ :| (a : as)) = last (a :| as)++-- | Extract everything except the last element of the stream.+init :: NonEmpty a -> [a]+init (_ :| []) = []+init (a1 :| (a2 : as)) = a1 : init (a2 :| as)++-- | Construct a 'NonEmpty' list from a single element.+--+-- @since 4.15+singleton :: a -> NonEmpty a+singleton a = a :| []++-- | Prepend an element to the stream.+(<|) :: a -> NonEmpty a -> NonEmpty a+a <| bs = a :| toList bs++-- | Synonym for '<|'.+cons :: a -> NonEmpty a -> NonEmpty a+cons = (<|)++-- | Sort a stream.+sort :: Ord a => NonEmpty a -> NonEmpty a+sort = lift List.sort++-- | Sort a 'NonEmpty' on a user-supplied projection of its elements.+-- See 'List.sortOn' for more detailed information.+--+-- ==== __Examples__+--+-- >>> sortOn fst $ (2, "world") :| [(4, "!"), (1, "Hello")]+-- (1,"Hello") :| [(2,"world"),(4,"!")]+--+-- >>> sortOn List.length ("jim" :| ["creed", "pam", "michael", "dwight", "kevin"])+-- "jim" :| ["pam","creed","kevin","dwight","michael"]+--+-- ==== __Performance notes__+--+-- This function minimises the projections performed, by materialising+-- the projections in an intermediate list.+--+-- For trivial projections, you should prefer using 'sortBy' with+-- 'comparing', for example:+--+-- >>> sortBy (comparing fst) $ (3, 1) :| [(2, 2), (1, 3)]+-- (1,3) :| [(2,2),(3,1)]+--+-- Or, for the exact same API as 'sortOn', you can use `sortBy . comparing`:+--+-- >>> (sortBy . comparing) fst $ (3, 1) :| [(2, 2), (1, 3)]+-- (1,3) :| [(2,2),(3,1)]+--+-- 'sortWith' is an alias for `sortBy . comparing`.+--+-- @since 4.20.0.0+sortOn :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a+sortOn f = lift (List.sortOn f)++-- | Converts a normal list to a 'NonEmpty' stream.+--+-- Raises an error if given an empty list.+fromList :: HasCallStack => [a] -> NonEmpty a+fromList (a:as) = a :| as+fromList [] = error "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++-- | The 'inits' function takes a stream @xs@ and returns all the+-- finite prefixes of @xs@, starting with the shortest. The result is+-- 'NonEmpty' because the result always contains the empty list as the first+-- element.+--+-- > inits [1,2,3] == [] :| [[1], [1,2], [1,2,3]]+-- > inits [1] == [] :| [[1]]+-- > inits [] == [] :| []+inits :: Foldable f => f a -> NonEmpty [a]+inits = fromList . List.inits . Foldable.toList++-- | The 'inits1' function takes a 'NonEmpty' stream @xs@ and returns all the+-- 'NonEmpty' finite prefixes of @xs@, starting with the shortest.+--+-- > inits1 (1 :| [2,3]) == (1 :| []) :| [1 :| [2], 1 :| [2,3]]+-- > inits1 (1 :| []) == (1 :| []) :| []+--+-- @since 4.18+inits1 :: NonEmpty a -> NonEmpty (NonEmpty a)+inits1 = fromList . List.inits1 . Foldable.toList++-- | The 'tails' function takes a stream @xs@ and returns all the+-- suffixes of @xs@, starting with the longest. The result is 'NonEmpty'+-- because the result always contains the empty list as the last element.+--+-- > tails [1,2,3] == [1,2,3] :| [[2,3], [3], []]+-- > tails [1] == [1] :| [[]]+-- > tails [] == [] :| []+tails   :: Foldable f => f a -> NonEmpty [a]+tails = fromList . List.tails . Foldable.toList++-- | The 'tails1' function takes a 'NonEmpty' stream @xs@ and returns all the+-- non-empty suffixes of @xs@, starting with the longest.+--+-- > tails1 (1 :| [2,3]) == (1 :| [2,3]) :| [2 :| [3], 3 :| []]+-- > tails1 (1 :| []) == (1 :| []) :| []+--+-- @since 4.18+tails1 :: NonEmpty a -> NonEmpty (NonEmpty a)+tails1 xs = xs :| List.tails1 (tail xs)++-- | @'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 = liftA2 (:|) 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, and consecutive equal elements+-- of the input end up in the same stream of the output list.+-- For example, in list notation:+--+-- >>> group "Mississippi"+-- ['M' :| "",'i' :| "",'s' :| "s",'i' :| "",'s' :| "s",'i' :| "",'p' :| "p",'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 'permutations' function returns the list of all permutations of the argument.+--+-- @since 4.20.0.0+permutations            :: [a] -> NonEmpty [a]+permutations xs0        =  xs0 :| perms xs0 []+  where+    perms []     _  = []+    perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is)+      where interleave    xs     r = let (_,zs) = interleave' id xs r in zs+            interleave' _ []     r = (ts, r)+            interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r+                                     in  (y:us, f (t:y:us) : zs)+-- The implementation of 'permutations' is adopted from 'GHC.Internal.Data.List.permutations',+-- see there for discussion and explanations.++-- | 'permutations1' operates like 'permutations', but uses the knowledge that its input is+-- non-empty to produce output where every element is non-empty.+--+-- > permutations1 = fmap fromList . permutations . toList+--+-- @since 4.20.0.0+permutations1 :: NonEmpty a -> NonEmpty (NonEmpty a)+permutations1 xs = fromList <$> permutations (toList xs)++-- | The 'isPrefixOf' 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.+(!!) :: HasCallStack => NonEmpty a -> Int -> a+(!!) (x :| xs) n+  | n == 0 = x+  | n > 0  = xs List.!! (n - 1)+  | otherwise = error "NonEmpty.!! negative index"+infixl 9 !!++-- | The 'unzip' function is the inverse of the 'zip' function.+unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)+unzip ((a, b) :| asbs) = (a :| as, b :| bs)+  where+    (as, bs) = List.unzip asbs++-- | The 'nub' function removes duplicate elements from a list. In+-- particular, it keeps only the first occurrence 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 'GHC.Internal.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 . toList+          . fmap toList++-- | 'sortBy' for 'NonEmpty', behaves the same as 'GHC.Internal.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++-- | A monomorphic version of '<>' for 'NonEmpty'.+--+-- >>> append (1 :| []) (2 :| [3])+-- 1 :| [2,3]+--+-- @since 4.16+append :: NonEmpty a -> NonEmpty a -> NonEmpty a+append = (<>)++-- | Attach a list at the end of a 'NonEmpty'.+--+-- >>> appendList (1 :| [2,3]) []+-- 1 :| [2,3]+--+-- >>> appendList (1 :| [2,3]) [4,5]+-- 1 :| [2,3,4,5]+--+-- @since 4.16+appendList :: NonEmpty a -> [a] -> NonEmpty a+appendList (x :| xs) ys = x :| xs <> ys++-- | Attach a list at the beginning of a 'NonEmpty'.+--+-- >>> prependList [] (1 :| [2,3])+-- 1 :| [2,3]+--+-- >>> prependList [negate 1, 0] (1 :| [2, 3])+-- -1 :| [0,1,2,3]+--+-- @since 4.16+prependList :: [a] -> NonEmpty a -> NonEmpty a+prependList ls ne = case ls of+  [] -> ne+  (x : xs) -> x :| xs <> toList ne
+ src/Data/Maybe.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Maybe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Maybe type, and associated operations.+--++module Data.Maybe+    (Maybe(Nothing, Just),+     maybe,+     isJust,+     isNothing,+     fromJust,+     fromMaybe,+     listToMaybe,+     maybeToList,+     catMaybes,+     mapMaybe+     ) where++import GHC.Internal.Data.Maybe
+ src/Data/Monoid.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Monoid+-- Copyright   :  (c) Andy Gill 2001,+--                (c) Oregon Graduate Institute of Science and Technology, 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- A type @a@ is a 'Monoid' if it provides an associative function ('<>')+-- that lets you combine any two values of type @a@ into one, and a neutral+-- element (`mempty`) such that+--+-- > a <> mempty == mempty <> a == a+--+-- A 'Monoid' is a 'Semigroup' with the added requirement of a neutral element.+-- Thus any 'Monoid' is a 'Semigroup', but not the other way around.+--+-- ==== __Examples__+--+-- The 'Sum' monoid is defined by the numerical addition operator and `0` as neutral element:+--+-- >>> import Data.Int+-- >>> mempty :: Sum Int+-- Sum {getSum = 0}+-- >>> Sum 1 <> Sum 2 <> Sum 3 <> Sum 4 :: Sum Int+-- Sum {getSum = 10}+--+-- We can combine multiple values in a list into a single value using the `mconcat` function.+-- Note that we have to specify the type here since 'Int' is a monoid under several different+-- operations:+--+-- >>> mconcat [1,2,3,4] :: Sum Int+-- Sum {getSum = 10}+-- >>> mconcat [] :: Sum Int+-- Sum {getSum = 0}+--+-- Another valid monoid instance of 'Int' is 'Product' It is defined by multiplication+-- and `1` as neutral element:+--+-- >>> Product 1 <> Product 2 <> Product 3 <> Product 4 :: Product Int+-- Product {getProduct = 24}+-- >>> mconcat [1,2,3,4] :: Product Int+-- Product {getProduct = 24}+-- >>> mconcat [] :: Product Int+-- Product {getProduct = 1}+--+--++module Data.Monoid+    (-- *  'Monoid' typeclass+     Monoid(..),+     (<>),+     Dual(..),+     Endo(..),+     -- *  'Bool' wrappers+     All(..),+     Any(..),+     -- *  'Num' wrappers+     Sum(..),+     Product(..),+     -- *  'Maybe' wrappers+     -- $MaybeExamples+     First(..),+     Last(..),+     -- *  'Alternative' wrapper+     Alt(..),+     -- *  'Applicative' wrapper+     Ap(..)+     ) where++import GHC.Internal.Data.Monoid+
+ src/Data/Ord.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Ord+-- Copyright   :  (c) The University of Glasgow 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Orderings+--++module Data.Ord+    (Ord(..),+     Ordering(..),+     Down(..),+     comparing,+     clamp+     ) where++import GHC.Internal.Data.Ord
+ src/Data/Proxy.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Proxy+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Definition of a Proxy type (poly-kinded in GHC)+--+-- @since 4.7.0.0++module Data.Proxy+    (Proxy(..),+     asProxyTypeOf,+     KProxy(..)+     ) where++import GHC.Internal.Data.Proxy
+ src/Data/Ratio.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Ratio+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Standard functions on rational numbers+--+-----------------------------------------------------------------------------++module Data.Ratio+    ( Ratio+    , Rational+    , (%)+    , numerator+    , denominator+    , approxRational++  ) where++import GHC.Internal.Real         -- The basic defns for Ratio+import Prelude++-- -----------------------------------------------------------------------------+-- approxRational++-- | 'approxRational', applied to two real fractional numbers @x@ and @epsilon@,+-- returns the simplest rational number within @epsilon@ of @x@.+-- A rational number @y@ is said to be /simpler/ than another @y'@ if+--+-- * @'abs' ('numerator' y) <= 'abs' ('numerator' y')@, and+--+-- * @'denominator' y <= 'denominator' y'@.+--+-- Any real interval contains a unique simplest rational;+-- in particular, note that @0\/1@ is the simplest rational of all.++-- Implementation details: Here, for simplicity, we assume a closed rational+-- interval.  If such an interval includes at least one whole number, then+-- the simplest rational is the absolutely least whole number.  Otherwise,+-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d+-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of+-- the simplest rational between d'%r' and d%r.++approxRational :: (RealFrac a) => a -> a -> Rational+approxRational rat eps =+    -- We convert rat and eps to rational *before* subtracting/adding since+    -- otherwise we may overflow. This was the cause of #14425.+    simplest (toRational rat - toRational eps) (toRational rat + toRational eps)+  where+    simplest x y+      | y < x      =  simplest y x+      | x == y     =  xr+      | x > 0      =  simplest' n d n' d'+      | y < 0      =  - simplest' (-n') d' (-n) d+      | otherwise  =  0 :% 1+      where xr  = toRational x+            n   = numerator xr+            d   = denominator xr+            nd' = toRational y+            n'  = numerator nd'+            d'  = denominator nd'++    simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+      | r == 0     =  q :% 1+      | q /= q'    =  (q+1) :% 1+      | otherwise  =  (q*n''+d'') :% n''+      where (q,r)      =  quotRem n d+            (q',r')    =  quotRem n' d'+            nd''       =  simplest' d' r' d r+            n''        =  numerator nd''+            d''        =  denominator nd''+
+ src/Data/STRef.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.STRef+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (uses Control.Monad.ST)+--+-- Mutable references in the (strict) ST monad.+--++module Data.STRef+    (-- *  STRefs+     STRef,+     newSTRef,+     readSTRef,+     writeSTRef,+     modifySTRef,+     modifySTRef'+     ) where++import GHC.Internal.Data.STRef
+ src/Data/STRef/Lazy.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.STRef.Lazy+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (uses Control.Monad.ST.Lazy)+--+-- Mutable references in the lazy ST monad.+--+-----------------------------------------------------------------------------++module Data.STRef.Lazy (+        -- * STRefs+        ST.STRef,       -- abstract+        newSTRef,+        readSTRef,+        writeSTRef,+        modifySTRef+ ) where++import Prelude+import GHC.Internal.Control.Monad.ST.Lazy+import qualified GHC.Internal.Data.STRef as ST++newSTRef    :: a -> ST s (ST.STRef s a)+readSTRef   :: ST.STRef s a -> ST s a+writeSTRef  :: ST.STRef s a -> a -> ST s ()+modifySTRef :: ST.STRef s a -> (a -> a) -> ST s ()++newSTRef        = strictToLazyST . ST.newSTRef+readSTRef       = strictToLazyST . ST.readSTRef+writeSTRef  r a = strictToLazyST (ST.writeSTRef r a)+modifySTRef r f = strictToLazyST (ST.modifySTRef r f)+
+ src/Data/STRef/Strict.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.STRef.Strict+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Control.Monad.ST.Strict)+--+-- Mutable references in the (strict) ST monad (re-export of "Data.STRef")+--++module Data.STRef.Strict (module Data.STRef) where++import Data.STRef
+ src/Data/Semigroup.hs view
@@ -0,0 +1,663 @@+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE Trustworthy                #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Semigroup+-- Copyright   :  (C) 2011-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A type @a@ is a 'Semigroup' if it provides an associative function ('<>')+-- that lets you combine any two values of type @a@ into one. Where being+-- associative means that the following must always hold:+--+-- prop> (a <> b) <> c == a <> (b <> c)+--+-- ==== __Examples__+--+-- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller+-- number:+--+-- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int+-- Min {getMin = 1}+--+-- If we need to combine multiple values we can use the 'sconcat' function+-- to do so. We need to ensure however that we have at least one value to+-- operate on, since otherwise our result would be undefined. It is for this+-- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that+-- can never be empty:+--+-- >>> (1 :| [])+-- 1 :| []+--+-- -- equivalent to [1] but guaranteed to be non-empty.+--+-- >>> (1 :| [2, 3, 4])+-- 1 :| [2,3,4]+--+-- -- equivalent to [1,2,3,4] but guaranteed to be non-empty.+--+-- Equipped with this guaranteed to be non-empty data structure, we can combine+-- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min'+-- and 'Max' instances of 'Int' which pick the smallest, or largest number+-- respectively:+--+-- >>> sconcat (1 :| [2, 3, 4]) :: Min Int+-- Min {getMin = 1}+--+-- >>> sconcat (1 :| [2, 3, 4]) :: Max Int+-- Max {getMax = 4}+--+-- String concatenation is another example of a 'Semigroup' instance:+--+-- >>> "foo" <> "bar"+-- "foobar"+--+-- A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid'+-- requires the presence of a neutral element ('mempty') in addition to the associative+-- operator. The requirement for a neutral element prevents many types from being a full Monoid,+-- like "Data.List.NonEmpty.NonEmpty".+--+-- Note that 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+  , Dual(..)+  , Endo(..)+  , All(..)+  , Any(..)+  , Sum(..)+  , Product(..)+  -- * Difference lists of a semigroup+  , diff+  , cycle1+  -- * ArgMin, ArgMax+  , Arg(..)+  , ArgMin+  , ArgMax+  ) where++import           GHC.Internal.Base hiding (Any, NonEmpty(..))+import           GHC.Internal.Enum+import           GHC.Internal.Show+import           GHC.Internal.Read+import           GHC.Internal.Num+import           GHC.Internal.Real+import           GHC.Internal.Data.Functor ((<$>))+import           Data.Bifoldable+import           Data.Bifunctor+import           Data.Bitraversable+import           GHC.Internal.Data.Foldable+import           GHC.Internal.Data.NonEmpty (NonEmpty(..))+import           GHC.Internal.Data.Traversable+import           GHC.Internal.Data.Semigroup.Internal+import           GHC.Internal.Control.Monad.Fix+import           GHC.Internal.Data.Data+import           GHC.Generics+import qualified GHC.Internal.List as List++-- $setup+-- >>> import Prelude+-- >>> import Data.List.NonEmpty (NonEmpty (..))+-- >>> import GHC.Internal.Data.Semigroup.Internal++-- | A generalization of 'GHC.Internal.Data.List.cycle' to an arbitrary 'Semigroup'.+-- May fail to terminate for some values in some semigroups.+--+-- ==== __Examples__+--+-- >>> take 10 $ cycle1 [1, 2, 3]+-- [1,2,3,1,2,3,1,2,3,1]+--+-- >>> cycle1 (Right 1)+-- Right 1+--+-- >>> cycle1 (Left 1)+-- * Hangs forever *+cycle1 :: Semigroup m => m -> m+cycle1 xs = xs' where xs' = xs <> xs'++-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.+--+-- ==== __Examples__+--+-- >>> let hello = diff "Hello, "+--+-- >>> appEndo hello "World!"+-- "Hello, World!"+--+-- >>> appEndo (hello <> mempty) "World!"+-- "Hello, World!"+--+-- >>> appEndo (mempty <> hello) "World!"+-- "Hello, World!"+--+-- >>> let world = diff "World"+-- >>> let excl = diff "!"+--+-- >>> appEndo (hello <> (world <> excl)) mempty+-- "Hello, World!"+--+-- >>> appEndo ((hello <> world) <> excl) mempty+-- "Hello, World!"+diff :: Semigroup m => m -> Endo m+diff = Endo . (<>)++-- | The 'Min' 'Monoid' and 'Semigroup' always choose the smaller element as+-- by the 'Ord' instance and 'min' of the contained type.+--+-- ==== __Examples__+--+-- >>> Min 42 <> Min 3+-- Min {getMin = 3}+--+-- >>> sconcat $ Min 1 :| [ Min n | n <- [2 .. 100]]+-- Min {getMin = 1}+newtype Min a = Min { getMin :: a }+  deriving ( Bounded  -- ^ @since 4.9.0.0+           , Eq       -- ^ @since 4.9.0.0+           , Ord      -- ^ @since 4.9.0.0+           , Show     -- ^ @since 4.9.0.0+           , Read     -- ^ @since 4.9.0.0+           , Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.9.0.0+instance Enum a => Enum (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 `fmap` enumFrom a+  enumFromThen (Min a) (Min b) = Min `fmap` enumFromThen a b+  enumFromTo (Min a) (Min b) = Min `fmap` enumFromTo a b+  enumFromThenTo (Min a) (Min b) (Min c) = Min `fmap` enumFromThenTo a b c+++-- | @since 4.9.0.0+instance Ord a => Semigroup (Min a) where+  (<>) = coerce (min :: a -> a -> a)+  stimes = stimesIdempotent++-- | @since 4.9.0.0+instance (Ord a, Bounded a) => Monoid (Min a) where+  mempty = maxBound+  -- By default, we would get a lazy right fold. This forces the use of a strict+  -- left fold instead.+  mconcat = List.foldl' (<>) mempty+  {-# INLINE mconcat #-}++-- | @since 4.9.0.0+instance Functor Min where+  fmap f (Min x) = Min (f x)++-- | @since 4.9.0.0+instance Foldable Min where+  foldMap f (Min a) = f a++-- | @since 4.9.0.0+instance Traversable Min where+  traverse f (Min a) = Min `fmap` f a++-- | @since 4.9.0.0+instance Applicative Min where+  pure = Min+  a <* _ = a+  _ *> a = a+  (<*>) = coerce+  liftA2 = coerce++-- | @since 4.9.0.0+instance Monad Min where+  (>>) = (*>)+  Min a >>= f = f a++-- | @since 4.9.0.0+instance MonadFix Min where+  mfix f = fix (f . getMin)++-- | @since 4.9.0.0+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++-- | The 'Max' 'Monoid' and 'Semigroup' always choose the bigger element as+-- by the 'Ord' instance and 'max' of the contained type.+--+-- ==== __Examples__+--+-- >>> Max 42 <> Max 3+-- Max {getMax = 42}+--+-- >>> sconcat $ Max 1 :| [ Max n | n <- [2 .. 100]]+-- Max {getMax = 100}+newtype Max a = Max { getMax :: a }+  deriving ( Bounded  -- ^ @since 4.9.0.0+           , Eq       -- ^ @since 4.9.0.0+           , Ord      -- ^ @since 4.9.0.0+           , Show     -- ^ @since 4.9.0.0+           , Read     -- ^ @since 4.9.0.0+           , Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.9.0.0+instance Enum a => Enum (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 `fmap` enumFrom a+  enumFromThen (Max a) (Max b) = Max `fmap` enumFromThen a b+  enumFromTo (Max a) (Max b) = Max `fmap` enumFromTo a b+  enumFromThenTo (Max a) (Max b) (Max c) = Max `fmap` enumFromThenTo a b c++-- | @since 4.9.0.0+instance Ord a => Semigroup (Max a) where+  (<>) = coerce (max :: a -> a -> a)+  stimes = stimesIdempotent++-- | @since 4.9.0.0+instance (Ord a, Bounded a) => Monoid (Max a) where+  mempty = minBound+  -- By default, we would get a lazy right fold. This forces the use of a strict+  -- left fold instead.+  mconcat = List.foldl' (<>) mempty+  {-# INLINE mconcat #-}++-- | @since 4.9.0.0+instance Functor Max where+  fmap f (Max x) = Max (f x)++-- | @since 4.9.0.0+instance Foldable Max where+  foldMap f (Max a) = f a++-- | @since 4.9.0.0+instance Traversable Max where+  traverse f (Max a) = Max `fmap` f a++-- | @since 4.9.0.0+instance Applicative Max where+  pure = Max+  a <* _ = a+  _ *> a = a+  (<*>) = coerce+  liftA2 = coerce++-- | @since 4.9.0.0+instance Monad Max where+  (>>) = (*>)+  Max a >>= f = f a++-- | @since 4.9.0.0+instance MonadFix Max where+  mfix f = fix (f . getMax)++-- | @since 4.9.0.0+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. In+-- the event of ties, the leftmost qualifying 'Arg' is chosen; contrast+-- with the behavior of 'minimum' and 'maximum' for many other types,+-- where ties are broken by considering elements to the left in the+-- structure to be less than elements to the right.+--+-- ==== __Examples__+--+-- >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ]+-- Arg 0 0+--+-- >>> maximum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ]+-- Arg 3.8 4.0+--+-- >>> minimum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ]+-- Arg (-34.0) (-10.0)+data Arg a b = Arg+  a+  -- ^ The argument used for comparisons in 'Eq' and 'Ord'.+  b+  -- ^ The "value" exposed via the 'Functor', 'Foldable' etc. instances.+  deriving+  ( Show     -- ^ @since 4.9.0.0+  , Read     -- ^ @since 4.9.0.0+  , Data     -- ^ @since 4.9.0.0+  , Generic  -- ^ @since 4.9.0.0+  , Generic1 -- ^ @since 4.9.0.0+  )++-- |+-- ==== __Examples__+--+-- >>> Min (Arg 0 ()) <> Min (Arg 1 ())+-- Min {getMin = Arg 0 ()}+--+-- >>> minimum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]]+-- Arg 3 "lea"+type ArgMin a b = Min (Arg a b)++-- |+-- ==== __Examples__+--+-- >>> Max (Arg 0 ()) <> Max (Arg 1 ())+-- Max {getMax = Arg 1 ()}+--+-- >>> maximum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]]+-- Arg 9 "violencia"+type ArgMax a b = Max (Arg a b)++-- | @since 4.9.0.0+instance Functor (Arg a) where+  fmap f (Arg x a) = Arg x (f a)++-- | @since 4.9.0.0+instance Foldable (Arg a) where+  foldMap f (Arg _ a) = f a++-- | @since 4.9.0.0+instance Traversable (Arg a) where+  traverse f (Arg x a) = Arg x `fmap` f a++-- |+-- Note that `Arg`'s 'Eq' instance does not satisfy extensionality:+--+-- >>> Arg 0 0 == Arg 0 1+-- True+-- >>> let f (Arg _ x) = x in f (Arg 0 0) == f (Arg 0 1)+-- False+--+-- @since 4.9.0.0+instance Eq a => Eq (Arg a b) where+  Arg a _ == Arg b _ = a == b++-- |+-- Note that `Arg`'s 'Ord' instance has 'min' and 'max' implementations that+-- differ from the tie-breaking conventions of the default implementation of+-- 'min' and 'max' in class 'Ord'; 'Arg' breaks ties by favoring the first+-- argument in both functions.+--+-- @since 4.9.0.0+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++-- | @since 4.9.0.0+instance Bifunctor Arg where+  bimap f g (Arg a b) = Arg (f a) (g b)++-- | @since 4.10.0.0+instance Bitraversable Arg where+  bitraverse f g (Arg a b) = Arg <$> f a <*> g b++-- | @since 4.10.0.0+instance Bifoldable Arg where+  bifoldMap f g (Arg a b) = f a <> g b++-- |+-- Beware that @Data.Semigroup.@'First' is different from+-- @Data.Monoid.@'Data.Monoid.First'. The former simply returns the first value,+-- so @Data.Semigroup.First Nothing <> x = Data.Semigroup.First Nothing@.+-- The latter returns the first non-'Nothing',+-- thus @Data.Monoid.First Nothing <> x = x@.+--+-- ==== __Examples__+--+-- >>> First 0 <> First 10+-- First {getFirst = 0}+--+-- >>> sconcat $ First 1 :| [ First n | n <- [2 ..] ]+-- First {getFirst = 1}+newtype First a = First { getFirst :: a }+  deriving ( Bounded  -- ^ @since 4.9.0.0+           , Eq       -- ^ @since 4.9.0.0+           , Ord      -- ^ @since 4.9.0.0+           , Show     -- ^ @since 4.9.0.0+           , Read     -- ^ @since 4.9.0.0+           , Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.9.0.0+instance Enum a => Enum (First a) where+  succ (First a) = First (succ a)+  pred (First a) = First (pred a)+  toEnum = First . toEnum+  fromEnum = fromEnum . getFirst+  enumFrom (First a) = First `fmap` enumFrom a+  enumFromThen (First a) (First b) = First `fmap` enumFromThen a b+  enumFromTo (First a) (First b) = First `fmap` enumFromTo a b+  enumFromThenTo (First a) (First b) (First c) = First `fmap` enumFromThenTo a b c++-- | @since 4.9.0.0+instance Semigroup (First a) where+  a <> _ = a+  stimes = stimesIdempotent+  sconcat (x :| _) = x++-- | @since 4.9.0.0+instance Functor First where+  fmap f (First x) = First (f x)++-- | @since 4.9.0.0+instance Foldable First where+  foldMap f (First a) = f a++-- | @since 4.9.0.0+instance Traversable First where+  traverse f (First a) = First `fmap` f a++-- | @since 4.9.0.0+instance Applicative First where+  pure x = First x+  a <* _ = a+  _ *> a = a+  (<*>) = coerce+  liftA2 = coerce++-- | @since 4.9.0.0+instance Monad First where+  (>>) = (*>)+  First a >>= f = f a++-- | @since 4.9.0.0+instance MonadFix First where+  mfix f = fix (f . getFirst)++-- |+-- Beware that @Data.Semigroup.@'Last' is different from+-- @Data.Monoid.@'Data.Monoid.Last'. The former simply returns the last value,+-- so @x <> Data.Semigroup.Last Nothing = Data.Semigroup.Last Nothing@.+-- The latter returns the last non-'Nothing',+-- thus @x <> Data.Monoid.Last Nothing = x@.+--+-- ==== __Examples__+--+-- >>> Last 0 <> Last 10+-- Last {getLast = 10}+--+-- >>> sconcat $ Last 1 :| [ Last n | n <- [2..]]+-- * Hangs forever *+newtype Last a = Last { getLast :: a }+  deriving ( Bounded  -- ^ @since 4.9.0.0+           , Eq       -- ^ @since 4.9.0.0+           , Ord      -- ^ @since 4.9.0.0+           , Show     -- ^ @since 4.9.0.0+           , Read     -- ^ @since 4.9.0.0+           , Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.9.0.0+instance Enum a => Enum (Last a) where+  succ (Last a) = Last (succ a)+  pred (Last a) = Last (pred a)+  toEnum = Last . toEnum+  fromEnum = fromEnum . getLast+  enumFrom (Last a) = Last `fmap` enumFrom a+  enumFromThen (Last a) (Last b) = Last `fmap` enumFromThen a b+  enumFromTo (Last a) (Last b) = Last `fmap` enumFromTo a b+  enumFromThenTo (Last a) (Last b) (Last c) = Last `fmap` enumFromThenTo a b c++-- | @since 4.9.0.0+instance Semigroup (Last a) where+  _ <> b = b+  stimes = stimesIdempotent++-- | @since 4.9.0.0+instance Functor Last where+  fmap f (Last x) = Last (f x)+  a <$ _ = Last a++-- | @since 4.9.0.0+instance Foldable Last where+  foldMap f (Last a) = f a++-- | @since 4.9.0.0+instance Traversable Last where+  traverse f (Last a) = Last `fmap` f a++-- | @since 4.9.0.0+instance Applicative Last where+  pure = Last+  a <* _ = a+  _ *> a = a+  (<*>) = coerce+  liftA2 = coerce++-- | @since 4.9.0.0+instance Monad Last where+  (>>) = (*>)+  Last a >>= f = f a++-- | @since 4.9.0.0+instance MonadFix Last where+  mfix f = fix (f . getLast)++-- | Provide a Semigroup for an arbitrary Monoid.+--+-- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of+-- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future.+newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }+  deriving ( Bounded  -- ^ @since 4.9.0.0+           , Eq       -- ^ @since 4.9.0.0+           , Ord      -- ^ @since 4.9.0.0+           , Show     -- ^ @since 4.9.0.0+           , Read     -- ^ @since 4.9.0.0+           , Data     -- ^ @since 4.9.0.0+           , Generic  -- ^ @since 4.9.0.0+           , Generic1 -- ^ @since 4.9.0.0+           )++-- | @since 4.9.0.0+instance Monoid m => Semigroup (WrappedMonoid m) where+  (<>) = coerce (mappend :: m -> m -> m)++-- | @since 4.9.0.0+instance Monoid m => Monoid (WrappedMonoid m) where+  mempty = WrapMonoid mempty+  -- This ensures that we use whatever mconcat is defined for the wrapped+  -- Monoid.+  mconcat = coerce (mconcat :: [m] -> m)++-- | @since 4.9.0.0+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 `fmap` enumFrom a+  enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid `fmap` enumFromThen a b+  enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid `fmap` enumFromTo a b+  enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) =+      WrapMonoid `fmap` enumFromThenTo a b c++-- | Repeat a value @n@ times.+--+-- > mtimesDefault n a = a <> a <> ... <> a  -- using <> (n-1) times+--+-- In many cases, @'stimes' 0 a@ for a `Monoid` will produce `mempty`.+-- However, there are situations when it cannot do so. In particular,+-- the following situation is fairly common:+--+-- @+-- data T a = ...+--+-- class Constraint1 a+-- class Constraint1 a => Constraint2 a+-- @+--+-- @+-- instance Constraint1 a => 'Semigroup' (T a)+-- instance Constraint2 a => 'Monoid' (T a)+-- @+--+-- Since @Constraint1@ is insufficient to implement 'mempty',+-- 'stimes' for @T a@ cannot do so.+--+-- When working with such a type, or when working polymorphically with+-- 'Semigroup' instances, @mtimesDefault@ should be used when the+-- multiplier might be zero. It is implemented using 'stimes' when+-- the multiplier is nonzero and 'mempty' when it is zero.+--+-- ==== __Examples__+--+-- >>> mtimesDefault 0 "bark"+-- ""+--+-- >>> mtimesDefault 3 "meow"+-- "meowmeowmeow"+mtimesDefault :: (Integral b, Monoid a) => b -> a -> a+mtimesDefault n x+  | n == 0    = mempty+  | otherwise = stimes n x
+ src/Data/String.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.String+-- Copyright   :  (c) The University of Glasgow 2007+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The @String@ type and associated operations.+--++module Data.String+    (String,+     IsString(..),+     -- *  Functions on strings+     lines,+     words,+     unlines,+     unwords+     ) where++import GHC.Internal.Data.String
+ src/Data/Traversable.hs view
@@ -0,0 +1,1112 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Data.Traversable+-- Copyright   :  Conor McBride and Ross Paterson 2005+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Class of data structures that can be traversed from left to right,+-- performing an action on each element.  Instances are expected to satisfy+-- the listed [laws](#laws).++module Data.Traversable (+    -- * The 'Traversable' class+    Traversable(..),+    -- * Utility functions+    for,+    forM,+    forAccumM,+    mapAccumL,+    mapAccumR,+    mapAccumM,+    -- * General definitions for superclass methods+    fmapDefault,+    foldMapDefault,++    -- * Overview+    -- $overview++    -- ** The 'traverse' and 'mapM' methods+    -- $traverse++    -- *** Their 'Foldable', just the effects, analogues.+    -- $effectful++    -- *** Result multiplicity+    -- $multiplicity++    -- ** The 'sequenceA' and 'sequence' methods+    -- $sequence++    -- *** Care with default method implementations+    -- $seqdefault++    -- *** Monadic short circuits+    -- $seqshort++    -- ** Example binary tree instance+    -- $tree_instance++    -- *** Pre-order and post-order tree traversal+    -- $tree_order++    -- ** Making construction intuitive+    --+    -- $construction++    -- * Advanced traversals+    -- $advanced++    -- *** Coercion+    -- $coercion++    -- ** Identity: the 'fmapDefault' function+    -- $identity++    -- ** State: the 'mapAccumL', 'mapAccumR' functions+    -- $stateful++    -- ** Const: the 'foldMapDefault' function+    -- $phantom++    -- ** ZipList: transposing lists of lists+    -- $ziplist++    -- * Laws+    --+    -- $laws++    -- * See also+    -- $also+    ) where++import GHC.Internal.Data.Traversable++-- $setup+-- >>> import Prelude+-- >>> import Data.Maybe+-- >>> import Data.Either+-- >>> import qualified Data.List as List+-- >>> :set -XExplicitForAll++-- $overview+--+-- #overview#+-- Traversable structures support element-wise sequencing of 'Applicative'+-- effects (thus also 'Monad' effects) to construct new structures of+-- __the same shape__ as the input.+--+-- To illustrate what is meant by /same shape/, if the input structure is+-- __@[a]@__, each output structure is a list __@[b]@__ of the same length as+-- the input.  If the input is a __@Tree a@__, each output __@Tree b@__ has the+-- same graph of intermediate nodes and leaves.  Similarly, if the input is a+-- 2-tuple __@(x, a)@__, each output is a 2-tuple __@(x, b)@__, and so forth.+--+-- It is in fact possible to decompose a traversable structure __@t a@__ into+-- its shape (a.k.a. /spine/) of type __@t ()@__ and its element list+-- __@[a]@__.  The original structure can be faithfully reconstructed from its+-- spine and element list.+--+-- The implementation of a @Traversable@ instance for a given structure follows+-- naturally from its type; see the [Construction](#construction) section for+-- details.+-- Instances must satisfy the laws listed in the [Laws section](#laws).+-- The diverse uses of @Traversable@ structures result from the many possible+-- choices of Applicative effects.+-- See the [Advanced Traversals](#advanced) section for some examples.+--+-- Every @Traversable@ structure is both a 'Functor' and 'Foldable' because it+-- is possible to implement the requisite instances in terms of 'traverse' by+-- using 'fmapDefault' for 'fmap' and 'foldMapDefault' for 'foldMap'.  Direct+-- fine-tuned implementations of these superclass methods can in some cases be+-- more efficient.++------------------++-- $traverse+-- For an 'Applicative' functor __@f@__ and a @Traversable@ functor __@t@__,+-- the type signatures of 'traverse' and 'fmap' are rather similar:+--+-- > fmap     :: (a -> f b) -> t a -> t (f b)+-- > traverse :: (a -> f b) -> t a -> f (t b)+--+-- The key difference is that 'fmap' produces a structure whose elements (of+-- type __@f b@__) are individual effects, while 'traverse' produces an+-- aggregate effect yielding structures of type __@t b@__.+--+-- For example, when __@f@__ is the __@IO@__ monad, and __@t@__ is __@List@__,+-- 'fmap' yields a list of IO actions, whereas 'traverse' constructs an IO+-- action that evaluates to a list of the return values of the individual+-- actions performed left-to-right.+--+-- > traverse :: (a -> IO b) -> [a] -> IO [b]+--+-- The 'mapM' function is a specialisation of 'traverse' to the case when+-- __@f@__ is a 'Monad'.  For monads, 'mapM' is more idiomatic than 'traverse'.+-- The two are otherwise generally identical (though 'mapM' may be specifically+-- optimised for monads, and could be more efficient than using the more+-- general 'traverse').+--+-- > traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)+-- > mapM     :: (Monad       m, Traversable t) => (a -> m b) -> t a -> m (t b)+--+-- When the traversable term is a simple variable or expression, and the+-- monadic action to run is a non-trivial do block, it can be more natural to+-- write the action last.  This idiom is supported by 'for', 'forM', and+-- 'forAccumM' which are the flipped versions of 'traverse', 'mapM', and+-- 'mapAccumM' respectively.++------------------++-- $multiplicity+--+-- #multiplicity#+-- When 'traverse' or 'mapM' is applied to an empty structure __@ts@__ (one for+-- which __@'null' ts@__ is 'True') the return value is __@pure ts@__+-- regardless of the provided function __@g :: a -> f b@__.  It is not possible+-- to apply the function when no values of type __@a@__ are available, but its+-- type determines the relevant instance of 'pure'.+--+-- prop> null ts ==> traverse g ts == pure ts+--+-- Otherwise, when __@ts@__ is non-empty and at least one value of type __@b@__+-- results from each __@f a@__, the structures __@t b@__ have /the same shape/+-- (list length, graph of tree nodes, ...) as the input structure __@t a@__,+-- but the slots previously occupied by elements of type __@a@__ now hold+-- elements of type __@b@__.+--+-- A single traversal may produce one, zero or many such structures.  The zero+-- case happens when one of the effects __@f a@__ sequenced as part of the+-- traversal yields no replacement values.  Otherwise, the many case happens+-- when one of sequenced effects yields multiple values.+--+-- The 'traverse' function does not perform selective filtering of slots in the+-- output structure as with e.g. 'Data.Maybe.mapMaybe'.+--+-- >>> let incOdd n = if odd n then Just $ n + 1 else Nothing+-- >>> mapMaybe incOdd [1, 2, 3]+-- [2,4]+-- >>> traverse incOdd [1, 3, 5]+-- Just [2,4,6]+-- >>> traverse incOdd [1, 2, 3]+-- Nothing+--+-- In the above examples, with 'Maybe' as the 'Applicative' __@f@__, we see+-- that the number of __@t b@__ structures produced by 'traverse' may differ+-- from one: it is zero when the result short-circuits to __@Nothing@__.  The+-- same can happen when __@f@__ is __@List@__ and the result is __@[]@__, or+-- __@f@__ is __@Either e@__ and the result is __@Left (x :: e)@__, or perhaps+-- the 'Control.Applicative.empty' value of some+-- 'Control.Applicative.Alternative' functor.+--+-- When __@f@__ is e.g. __@List@__, and the map __@g :: a -> [b]@__ returns+-- more than one value for some inputs __@a@__ (and at least one for all+-- __@a@__), the result of __@mapM g ts@__ will contain multiple structures of+-- the same shape as __@ts@__:+--+-- prop> List.length (mapM g ts) == List.product (fmap (List.length . g) ts)+--+-- For example:+--+-- >>> List.length $ mapM (\n -> [1..n]) [1..6]+-- 720+-- >>> List.product $ List.length . (\n -> [1..n]) <$> [1..6]+-- 720+--+-- In other words, a traversal with a function __@g :: a -> [b]@__, over an+-- input structure __@t a@__, yields a list __@[t b]@__, whose length is the+-- product of the lengths of the lists that @g@ returns for each element of the+-- input structure!  The individual elements __@a@__ of the structure are+-- replaced by each element of __@g a@__ in turn:+--+-- >>> mapM (\n -> [1..n]) $ Just 3+-- [Just 1,Just 2,Just 3]+-- >>> mapM (\n -> [1..n]) [1..3]+-- [[1,1,1],[1,1,2],[1,1,3],[1,2,1],[1,2,2],[1,2,3]]+--+-- If any element of the structure __@t a@__ is mapped by @g@ to an empty list,+-- then the entire aggregate result is empty, because no value is available to+-- fill one of the slots of the output structure:+--+-- >>> mapM (\n -> [1..n]) $ [0..6] -- [1..0] is empty+-- []++------------------++-- $effectful+-- #effectful#+--+-- The 'traverse' and 'mapM' methods have analogues in the "Data.Foldable"+-- module.  These are 'traverse_' and 'mapM_', and their flipped variants+-- 'for_' and 'forM_', respectively.  The result type is __@f ()@__, they don't+-- return an updated structure, and can be used to sequence effects over all+-- the elements of a @Traversable@ (any 'Foldable') structure just for their+-- side-effects.+--+-- If the @Traversable@ structure is empty, the result is __@pure ()@__.  When+-- effects short-circuit, the __@f ()@__ result may, for example, be 'Nothing'+-- if __@f@__ is 'Maybe', or __@'Left' e@__ when it is __@'Either' e@__.+--+-- It is perhaps worth noting that 'Maybe' is not only a potential+-- 'Applicative' functor for the return value of the first argument of+-- 'traverse', but is also itself a 'Traversable' structure with either zero or+-- one element.  A convenient idiom for conditionally executing an action just+-- for its effects on a 'Just' value, and doing nothing otherwise is:+--+-- > -- action :: Monad m => a -> m ()+-- > -- mvalue :: Maybe a+-- > mapM_ action mvalue -- :: m ()+--+-- which is more concise than:+--+-- > maybe (return ()) action mvalue+--+-- The 'mapM_' idiom works verbatim if the type of __@mvalue@__ is later+-- refactored from __@Maybe a@__ to __@Either e a@__ (assuming it remains OK to+-- silently do nothing in the 'Left' case).++------------------++-- $sequence+--+-- #sequence#+-- The 'sequenceA' and 'sequence' methods are useful when what you have is a+-- container of pending applicative or monadic effects, and you want to combine+-- them into a single effect that produces zero or more containers with the+-- computed values.+--+-- > sequenceA :: (Applicative f, Traversable t) => t (f a) -> f (t a)+-- > sequence  :: (Monad       m, Traversable t) => t (m a) -> m (t a)+-- > sequenceA = traverse id -- default definition+-- > sequence  = sequenceA   -- default definition+--+-- When the monad __@m@__ is 'System.IO.IO', applying 'sequence' to a list of+-- IO actions, performs each in turn, returning a list of the results:+--+-- > sequence [putStr "Hello ", putStrLn "World!"]+-- >     = (\a b -> [a,b]) <$> putStr "Hello " <*> putStrLn "World!"+-- >     = do u1 <- putStr "Hello "+-- >          u2 <- putStrLn "World!"+-- >          return [u1, u2]         -- In this case  [(), ()]+--+-- For 'sequenceA', the /non-deterministic/ behaviour of @List@ is most easily+-- seen in the case of a list of lists (of elements of some common fixed type).+-- The result is a cross-product of all the sublists:+--+-- >>> sequenceA [[0, 1, 2], [30, 40], [500]]+-- [[0,30,500],[0,40,500],[1,30,500],[1,40,500],[2,30,500],[2,40,500]]+--+-- Because the input list has three (sublist) elements, the result is a list of+-- triples (/same shape/).++------------------++-- $seqshort+--+-- #seqshort#+-- When the monad __@m@__ is 'Either' or 'Maybe' (more generally any+-- 'Control.Monad.MonadPlus'), the effect in question is to short-circuit the+-- result on encountering 'Left' or 'Nothing' (more generally+-- 'Control.Monad.mzero').+--+-- >>> sequence [Just 1,Just 2,Just 3]+-- Just [1,2,3]+-- >>> sequence [Just 1,Nothing,Just 3]+-- Nothing+-- >>> sequence [Right 1,Right 2,Right 3]+-- Right [1,2,3]+-- >>> sequence [Right 1,Left "sorry",Right 3]+-- Left "sorry"+--+-- The result of 'sequence' is all-or-nothing, either structures of exactly the+-- same shape as the input or none at all.  The 'sequence' function does not+-- perform selective filtering as with e.g. 'Data.Maybe.catMaybes' or+-- 'Data.Either.rights':+--+-- >>> catMaybes [Just 1,Nothing,Just 3]+-- [1,3]+-- >>> rights [Right 1,Left "sorry",Right 3]+-- [1,3]++------------------++-- $seqdefault+--+-- #seqdefault#+-- The 'traverse' method has a default implementation in terms of 'sequenceA':+--+-- > traverse g = sequenceA . fmap g+--+-- but relying on this default implementation is not recommended, it requires+-- that the structure is already independently a 'Functor'.  The definition of+-- 'sequenceA' in terms of __@traverse id@__ is much simpler than 'traverse'+-- expressed via a composition of 'sequenceA' and 'fmap'.  Instances should+-- generally implement 'traverse' explicitly.  It may in some cases also make+-- sense to implement a specialised 'mapM'.+--+-- Because 'fmapDefault' is defined in terms of 'traverse' (whose default+-- definition in terms of 'sequenceA' uses 'fmap'), you must not use+-- 'fmapDefault' to define the @Functor@ instance if the @Traversable@ instance+-- directly defines only 'sequenceA'.++------------------++-- $tree_instance+--+-- #tree#+-- The definition of a 'Traversable' instance for a binary tree is rather+-- similar to the corresponding instance of 'Functor', given the data type:+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a canonical @Functor@ instance would be+--+-- > instance Functor Tree where+-- >    fmap g Empty        = Empty+-- >    fmap g (Leaf x)     = Leaf (g x)+-- >    fmap g (Node l k r) = Node (fmap g l) (g k) (fmap g r)+--+-- a canonical @Traversable@ instance would be+--+-- > instance Traversable Tree where+-- >    traverse g Empty        = pure Empty+-- >    traverse g (Leaf x)     = Leaf <$> g x+-- >    traverse g (Node l k r) = Node <$> traverse g l <*> g k <*> traverse g r+--+-- This definition works for any __@g :: a -> f b@__, with __@f@__ an+-- Applicative functor, as the laws for @('<*>')@ imply the requisite+-- associativity.+--+-- We can add an explicit non-default 'mapM' if desired:+--+-- >    mapM g Empty        = return Empty+-- >    mapM g (Leaf x)     = Leaf <$> g x+-- >    mapM g (Node l k r) = do+-- >        ml <- mapM g l+-- >        mk <- g k+-- >        mr <- mapM g r+-- >        return $ Node ml mk mr+--+-- See [Construction](#construction) below for a more detailed exploration of+-- the general case, but as mentioned in [Overview](#overview) above, instance+-- definitions are typically rather simple, all the interesting behaviour is a+-- result of an interesting choice of 'Applicative' functor for a traversal.++-- $tree_order+--+-- It is perhaps worth noting that the traversal defined above gives an+-- /in-order/ sequencing of the elements.  If instead you want either+-- /pre-order/ (parent first, then child nodes) or post-order (child nodes+-- first, then parent) sequencing, you can define the instance accordingly:+--+-- > inOrderNode :: Tree a -> a -> Tree a -> Tree a+-- > inOrderNode l x r = Node l x r+-- >+-- > preOrderNode :: a -> Tree a -> Tree a -> Tree a+-- > preOrderNode x l r = Node l x r+-- >+-- > postOrderNode :: Tree a -> Tree a -> a -> Tree a+-- > postOrderNode l r x = Node l x r+-- >+-- > -- Traversable instance with in-order traversal+-- > instance Traversable Tree where+-- >     traverse g t = case t of+-- >         Empty      -> pure Empty+-- >         Leaf x     -> Leaf <$> g x+-- >         Node l x r -> inOrderNode <$> traverse g l <*> g x <*> traverse g r+-- >+-- > -- Traversable instance with pre-order traversal+-- > instance Traversable Tree where+-- >     traverse g t = case t of+-- >         Empty      -> pure Empty+-- >         Leaf x     -> Leaf <$> g x+-- >         Node l x r -> preOrderNode <$> g x <*> traverse g l <*> traverse g r+-- >+-- > -- Traversable instance with post-order traversal+-- > instance Traversable Tree where+-- >     traverse g t = case t of+-- >         Empty      -> pure Empty+-- >         Leaf x     -> Leaf <$> g x+-- >         Node l x r -> postOrderNode <$> traverse g l <*> traverse g r <*> g x+--+-- Since the same underlying Tree structure is used in all three cases, it is+-- possible to use @newtype@ wrappers to make all three available at the same+-- time!  The user need only wrap the root of the tree in the appropriate+-- @newtype@ for the desired traversal order.  Tne associated instance+-- definitions are shown below (see [coercion](#coercion) if unfamiliar with+-- the use of 'coerce' in the sample code):+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- >+-- > -- Default in-order traversal+-- >+-- > import Data.Coerce (coerce)+-- > import Data.Traversable+-- >+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+-- > instance Functor  Tree where fmap    = fmapDefault+-- > instance Foldable Tree where foldMap = foldMapDefault+-- >+-- > instance Traversable Tree where+-- >     traverse _ Empty = pure Empty+-- >     traverse g (Leaf a) = Leaf <$> g a+-- >     traverse g (Node l a r) = Node <$> traverse g l <*> g a <*> traverse g r+-- >+-- > -- Optional pre-order traversal+-- >+-- > newtype PreOrderTree a = PreOrderTree (Tree a)+-- > instance Functor  PreOrderTree where fmap    = fmapDefault+-- > instance Foldable PreOrderTree where foldMap = foldMapDefault+-- >+-- > instance Traversable PreOrderTree where+-- >     traverse _ (PreOrderTree Empty)        = pure $ preOrderEmpty+-- >     traverse g (PreOrderTree (Leaf x))     = preOrderLeaf <$> g x+-- >     traverse g (PreOrderTree (Node l x r)) = preOrderNode+-- >         <$> g x+-- >         <*> traverse g (coerce l)+-- >         <*> traverse g (coerce r)+-- >+-- > preOrderEmpty :: forall a. PreOrderTree a+-- > preOrderEmpty = coerce (Empty @a)+-- > preOrderLeaf :: forall a. a -> PreOrderTree a+-- > preOrderLeaf = coerce (Leaf @a)+-- > preOrderNode :: a -> PreOrderTree a -> PreOrderTree a -> PreOrderTree a+-- > preOrderNode x l r = coerce (Node (coerce l) x (coerce r))+-- >+-- > -- Optional post-order traversal+-- >+-- > newtype PostOrderTree a = PostOrderTree (Tree a)+-- > instance Functor  PostOrderTree where fmap    = fmapDefault+-- > instance Foldable PostOrderTree where foldMap = foldMapDefault+-- >+-- > instance Traversable PostOrderTree where+-- >     traverse _ (PostOrderTree Empty)        = pure postOrderEmpty+-- >     traverse g (PostOrderTree (Leaf x))     = postOrderLeaf <$> g x+-- >     traverse g (PostOrderTree (Node l x r)) = postOrderNode+-- >         <$> traverse g (coerce l)+-- >         <*> traverse g (coerce r)+-- >         <*> g x+-- >+-- > postOrderEmpty :: forall a. PostOrderTree a+-- > postOrderEmpty = coerce (Empty @a)+-- > postOrderLeaf :: forall a. a -> PostOrderTree a+-- > postOrderLeaf = coerce (Leaf @a)+-- > postOrderNode :: PostOrderTree a -> PostOrderTree a -> a -> PostOrderTree a+-- > postOrderNode l r x = coerce (Node (coerce l) x (coerce r))+--+-- With the above, given a sample tree:+--+-- > inOrder :: Tree Int+-- > inOrder = Node (Node (Leaf 10) 3 (Leaf 20)) 5 (Leaf 42)+--+-- we have:+--+-- > import Data.Foldable (toList)+-- > print $ toList inOrder+-- > [10,3,20,5,42]+-- >+-- > print $ toList (coerce inOrder :: PreOrderTree Int)+-- > [5,3,10,20,42]+-- >+-- > print $ toList (coerce inOrder :: PostOrderTree Int)+-- > [10,20,3,42,5]+--+-- You would typically define instances for additional common type classes,+-- such as 'Eq', 'Ord', 'Show', etc.++------------------++-- $construction+--+-- #construction#+-- In order to be able to reason about how a given type of 'Applicative'+-- effects will be sequenced through a general 'Traversable' structure by its+-- 'traversable' and related methods, it is helpful to look more closely+-- at how a general 'traverse' method is implemented.  We'll look at how+-- general traversals are constructed primarily with a view to being able+-- to predict their behaviour as a user, even if you're not defining your+-- own 'Traversable' instances.+--+-- Traversable structures __@t a@__ are assembled incrementally from their+-- constituent parts, perhaps by prepending or appending individual elements of+-- type __@a@__, or, more generally, by recursively combining smaller composite+-- traversable building blocks that contain multiple such elements.+--+-- As in the [tree example](#tree) above, the components being combined are+-- typically pieced together by a suitable /constructor/, i.e. a function+-- taking two or more arguments that returns a composite value.+--+-- The 'traverse' method enriches simple incremental construction with+-- threading of 'Applicative' effects of some function __@g :: a -> f b@__.+--+-- The basic building blocks we'll use to model the construction of 'traverse'+-- are a hypothetical set of elementary functions, some of which may have+-- direct analogues in specific @Traversable@ structures.  For example, the+-- __@(':')@__ constructor is an analogue for lists of @prepend@ or the more+-- general @combine@.+--+-- > empty :: t a               -- build an empty container+-- > singleton :: a -> t a      -- build a one-element container+-- > prepend :: a -> t a -> t a -- extend by prepending a new initial element+-- > append  :: t a -> a -> t a -- extend by appending a new final element+-- > combine :: a1 -> a2 -> ... -> an -> t a -- combine multiple inputs+--+-- * An empty structure has no elements of type __@a@__, so there's nothing+--   to which __@g@__ can be applied, but since we need an output of type+--   __@f (t b)@__, we just use the 'pure' instance of __@f@__ to wrap an+--   empty of type __@t b@__:+--+--     > traverse _ (empty :: t a) = pure (empty :: t b)+--+--     With the List monad, /empty/ is __@[]@__, while with 'Maybe' it is+--     'Nothing'.  With __@Either e a@__ we have an /empty/ case for each+--     value of __@e@__:+--+--     > traverse _ (Left e :: Either e a) = pure $ (Left e :: Either e b)+--+-- * A singleton structure has just one element of type __@a@__, and+--   'traverse' can take that __@a@__, apply __@g :: a -> f b@__ getting an+--   __@f b@__, then __@fmap singleton@__ over that, getting an __@f (t b)@__+--   as required:+--+--     > traverse g (singleton a) = fmap singleton $ g a+--+--     Note that if __@f@__ is __@List@__ and __@g@__ returns multiple values+--     the result will be a list of multiple __@t b@__ singletons!+--+--     Since 'Maybe' and 'Either' are either empty or singletons, we have+--+--     > traverse _ Nothing = pure Nothing+--     > traverse g (Just a) = Just <$> g a+--+--     > traverse _ (Left e) = pure (Left e)+--     > traverse g (Right a) = Right <$> g a+--+--     For @List@, empty is __@[]@__ and @singleton@ is __@(:[])@__, so we have:+--+--     > traverse _ []  = pure []+--     > traverse g [a] = fmap (:[]) (g a)+--     >                = (:) <$> (g a) <*> traverse g []+--     >                = liftA2 (:) (g a) (traverse g [])+--+-- * When the structure is built by adding one more element via __@prepend@__+--   or __@append@__, traversal amounts to:+--+--     > traverse g (prepend a t0) = prepend <$> (g a) <*> traverse g t0+--     >                           = liftA2 prepend (g a) (traverse g t0)+--+--     > traverse g (append t0 a) = append <$> traverse g t0 <*> g a+--     >                          = liftA2 append (traverse g t0) (g a)+--+--     The origin of the combinatorial product when __@f@__ is @List@ should now+--     be apparent, when __@traverse g t0@__ has __@n@__ elements and __@g a@__+--     has __@m@__ elements, the /non-deterministic/ 'Applicative' instance of+--     @List@ will produce a result with __@m * n@__ elements.+--+-- * When combining larger building blocks, we again use __@('<*>')@__ to+--   combine the traversals of the components.  With bare elements __@a@__+--   mapped to __@f b@__ via __@g@__, and composite traversable+--   sub-structures transformed via __@traverse g@__:+--+--     > traverse g (combine a1 a2 ... an) =+--     >     combine <$> t1 <*> t2 <*> ... <*> tn+--     >   where+--     >      t1 = g a1          -- if a1 fills a slot of type @a@+--     >         = traverse g a1 -- if a1 is a traversable substructure+--     >      ... ditto for the remaining constructor arguments ...+--+-- The above definitions sequence the 'Applicative' effects of __@f@__ in the+-- expected order while producing results of the expected shape __@t@__.+--+-- For lists this becomes:+--+-- > traverse g [] = pure []+-- > traverse g (x:xs) = liftA2 (:) (g a) (traverse g xs)+--+-- The actual definition of 'traverse' for lists is an equivalent+-- right fold in order to facilitate list /fusion/.+--+-- > traverse g = foldr (\x r -> liftA2 (:) (g x) r) (pure [])++------------------++-- $advanced+--+-- #advanced#+-- In the sections below we'll examine some advanced choices of 'Applicative'+-- effects that give rise to very different transformations of @Traversable@+-- structures.+--+-- These examples cover the implementations of 'fmapDefault', 'foldMapDefault',+-- 'mapAccumL' and 'mapAccumR' functions illustrating the use of 'Identity',+-- 'Const' and stateful 'Applicative' effects.  The [ZipList](#ziplist) example+-- illustrates the use of a less-well known 'Applicative' instance for lists.+--+-- This is optional material, which is not essential to a basic understanding of+-- @Traversable@ structures.  If this is your first encounter with @Traversable@+-- structures, you can come back to these at a later date.++-- $coercion+--+-- #coercion#+-- Some of the examples make use of an advanced Haskell feature, namely+-- @newtype@ /coercion/.  This is done for two reasons:+--+-- * Use of 'coerce' makes it possible to avoid cluttering the code with+--   functions that wrap and unwrap /newtype/ terms, which at runtime are+--   indistinguishable from the underlying value.  Coercion is particularly+--   convenient when one would have to otherwise apply multiple newtype+--   constructors to function arguments, and then peel off multiple layers+--   of same from the function output.+--+-- * Use of 'coerce' can produce more efficient code, by reusing the original+--   value, rather than allocating space for a wrapped clone.+--+-- If you're not familiar with 'coerce', don't worry, it is just a shorthand+-- that, e.g., given:+--+-- > newtype Foo a = MkFoo { getFoo :: a }+-- > newtype Bar a = MkBar { getBar :: a }+-- > newtype Baz a = MkBaz { getBaz :: a }+-- > f :: Baz Int -> Bar (Foo String)+--+-- makes it possible to write:+--+-- > x :: Int -> String+-- > x = coerce f+--+-- instead of+--+-- > x = getFoo . getBar . f . MkBaz++------------------++-- $identity+--+-- #identity#+-- The simplest Applicative functor is 'Identity', which just wraps and unwraps+-- pure values and function application.  This allows us to define+-- 'fmapDefault':+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- > import Data.Coercible (coerce)+-- >+-- > fmapDefault :: forall t a b. Traversable t => (a -> b) -> t a -> t b+-- > fmapDefault = coerce (traverse @t @Identity @a @b)+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap terms via 'Identity' and 'runIdentity'.+--+-- As noted in [Overview](#overview), 'fmapDefault' can only be used to define+-- the requisite 'Functor' instance of a 'Traversable' structure when the+-- 'traverse' method is explicitly implemented.  An infinite loop would result+-- if in addition 'traverse' were defined in terms of 'sequenceA' and 'fmap'.++------------------++-- $stateful+--+-- #stateful#+-- Applicative functors that thread a changing state through a computation are+-- an interesting use-case for 'traverse'.  The 'mapAccumL' and 'mapAccumR'+-- functions in this module are each defined in terms of such traversals.+--+-- We first define a simplified (not a monad transformer) version of+-- 'Control.Monad.Trans.State.State' that threads a state __@s@__ through a+-- chain of computations left to right.  Its @('<*>')@ operator passes the+-- input state first to its left argument, and then the resulting state is+-- passed to its right argument, which returns the final state.+--+-- > newtype StateL s a = StateL { runStateL :: s -> (s, a) }+-- >+-- > instance Functor (StateL s) where+-- >     fmap f (StateL kx) = StateL $ \ s ->+-- >         let (s', x) = kx s in (s', f x)+-- >+-- > instance Applicative (StateL s) where+-- >     pure a = StateL $ \s -> (s, a)+-- >     (StateL kf) <*> (StateL kx) = StateL $ \ s ->+-- >         let { (s',  f) = kf s+-- >             ; (s'', x) = kx s' } in (s'', f x)+-- >     liftA2 f (StateL kx) (StateL ky) = StateL $ \ s ->+-- >         let { (s',  x) = kx s+-- >             ; (s'', y) = ky s' } in (s'', f x y)+--+-- With @StateL@, we can define 'mapAccumL' as follows:+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- > mapAccumL :: forall t s a b. Traversable t+-- >           => (s -> a -> (s, b)) -> s -> t a -> (s, t b)+-- > mapAccumL g s ts = coerce (traverse @t @(StateL s) @a @b) (flip g) ts s+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap __@newtype@__ terms.+--+-- The type of __@flip g@__ is coercible to __@a -> StateL b@__, which makes it+-- suitable for use with 'traverse'.  As part of the Applicative+-- [construction](#construction) of __@StateL (t b)@__ the state updates will+-- thread left-to-right along the sequence of elements of __@t a@__.+--+-- While 'mapAccumR' has a type signature identical to 'mapAccumL', it differs+-- in the expected order of evaluation of effects, which must take place+-- right-to-left.+--+-- For this we need a variant control structure @StateR@, which threads the+-- state right-to-left, by passing the input state to its right argument and+-- then using the resulting state as an input to its left argument:+--+-- > newtype StateR s a = StateR { runStateR :: s -> (s, a) }+-- >+-- > instance Functor (StateR s) where+-- >     fmap f (StateR kx) = StateR $ \s ->+-- >         let (s', x) = kx s in (s', f x)+-- >+-- > instance Applicative (StateR s) where+-- >     pure a = StateR $ \s -> (s, a)+-- >     (StateR kf) <*> (StateR kx) = StateR $ \ s ->+-- >         let { (s',  x) = kx s+-- >             ; (s'', f) = kf s' } in (s'', f x)+-- >     liftA2 f (StateR kx) (StateR ky) = StateR $ \ s ->+-- >         let { (s',  y) = ky s+-- >             ; (s'', x) = kx s' } in (s'', f x y)+--+-- With @StateR@, we can define 'mapAccumR' as follows:+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- > mapAccumR :: forall t s a b. Traversable t+-- >           => (s -> a -> (s, b)) -> s -> t a -> (s, t b)+-- > mapAccumR g s0 ts = coerce (traverse @t @(StateR s) @a @b) (flip g) ts s0+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap __@newtype@__ terms.+--+-- Various stateful traversals can be constructed from 'mapAccumL' and+-- 'mapAccumR' for suitable choices of @g@, or built directly along similar+-- lines.++------------------++-- $phantom+--+-- #phantom#+-- The 'Const' Functor enables applications of 'traverse' that summarise the+-- input structure to an output value without constructing any output values+-- of the same type or shape.+--+-- As noted [above](#overview), the @Foldable@ superclass constraint is+-- justified by the fact that it is possible to construct 'foldMap', 'foldr',+-- etc., from 'traverse'.  The technique used is useful in its own right, and+-- is explored below.+--+-- A key feature of folds is that they can reduce the input structure to a+-- summary value. Often neither the input structure nor a mutated clone is+-- needed once the fold is computed, and through list fusion the input may not+-- even have been memory resident in its entirety at the same time.+--+-- The 'traverse' method does not at first seem to be a suitable building block+-- for folds, because its return value __@f (t b)@__ appears to retain mutated+-- copies of the input structure.  But the presence of __@t b@__ in the type+-- signature need not mean that terms of type __@t b@__ are actually embedded+-- in __@f (t b)@__.  The simplest way to elide the excess terms is by basing+-- the Applicative functor used with 'traverse' on 'Const'.+--+-- Not only does __@Const a b@__ hold just an __@a@__ value, with the __@b@__+-- parameter merely a /phantom/ type, but when __@m@__ has a 'Monoid' instance,+-- __@Const m@__ is an 'Applicative' functor:+--+-- > import Data.Coerce (coerce)+-- > newtype Const a b = Const { getConst :: a } deriving (Eq, Ord, Show) -- etc.+-- > instance Functor (Const m) where fmap = const coerce+-- > instance Monoid m => Applicative (Const m) where+-- >    pure _   = Const mempty+-- >    (<*>)    = coerce (mappend :: m -> m -> m)+-- >    liftA2 _ = coerce (mappend :: m -> m -> m)+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap __@newtype@__ terms.+--+-- We can therefore define a specialisation of 'traverse':+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- > traverseC :: forall t a m. (Monoid m, Traversable t)+-- >           => (a -> Const m ()) -> t a -> Const m (t ())+-- > traverseC = traverse @t @(Const m) @a @()+--+-- For which the Applicative [construction](#construction) of 'traverse'+-- leads to:+--+-- prop> null ts ==> traverseC g ts = Const mempty+-- prop> traverseC g (prepend x xs) = Const (g x) <> traverseC g xs+--+-- In other words, this makes it possible to define:+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- > foldMapDefault :: forall t a m. (Monoid m, Traversable t) => (a -> m) -> t a -> m+-- > foldMapDefault = coerce (traverse @t @(Const m) @a @())+--+-- Which is sufficient to define a 'Foldable' superclass instance:+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap __@newtype@__ terms.+--+-- > instance Traversable t => Foldable t where foldMap = foldMapDefault+--+-- It may however be instructive to also directly define candidate default+-- implementations of 'foldr' and 'foldl'', which take a bit more machinery+-- to construct:+--+-- > {-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+-- > import Data.Coerce (coerce)+-- > import Data.Functor.Const (Const(..))+-- > import Data.Semigroup (Dual(..), Endo(..))+-- > import GHC.Exts (oneShot)+-- >+-- > foldrDefault :: forall t a b. Traversable t+-- >              => (a -> b -> b) -> b -> t a -> b+-- > foldrDefault f z = \t ->+-- >     coerce (traverse @t @(Const (Endo b)) @a @()) f t z+-- >+-- > foldlDefault' :: forall t a b. Traversable t => (b -> a -> b) -> b -> t a -> b+-- > foldlDefault' f z = \t ->+-- >     coerce (traverse @t @(Const (Dual (Endo b))) @a @()) f' t z+-- >   where+-- >     f' :: a -> b -> b+-- >     f' a = oneShot $ \ b -> b `seq` f b a+--+-- In the above we're using the __@'Data.Monoid.Endo' b@__ 'Monoid' and its+-- 'Dual' to compose a sequence of __@b -> b@__ accumulator updates in either+-- left-to-right or right-to-left order.+--+-- The use of 'seq' in the definition of __@foldlDefault'@__ ensures strictness+-- in the accumulator.+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap __@newtype@__ terms.+--+-- The 'GHC.Exts.oneShot' function gives a hint to the compiler that aids in+-- correct optimisation of lambda terms that fire at most once (for each+-- element __@a@__) and so should not try to pre-compute and re-use+-- subexpressions that pay off only on repeated execution.  Otherwise, it is+-- just the identity function.++------------------++-- $ziplist+--+-- #ziplist#+-- As a warm-up for looking at the 'ZipList' 'Applicative' functor, we'll first+-- look at a simpler analogue.  First define a fixed width 2-element @Vec2@+-- type, whose 'Applicative' instance combines a pair of functions with a pair of+-- values by applying each function to the corresponding value slot:+--+-- > data Vec2 a = Vec2 a a+-- > instance Functor Vec2 where+-- >     fmap f (Vec2 a b) = Vec2 (f a) (f b)+-- > instance Applicative Vec2 where+-- >     pure x = Vec2 x x+-- >     liftA2 f (Vec2 a b) (Vec2 p q) = Vec2 (f a p) (f b q)+-- > instance Foldable Vec2 where+-- >     foldr f z (Vec2 a b) = f a (f b z)+-- >     foldMap f (Vec2 a b) = f a <> f b+-- > instance Traversable Vec2 where+-- >     traverse f (Vec2 a b) = Vec2 <$> f a <*> f b+--+-- Along with a similar definition for fixed width 3-element vectors:+--+-- > data Vec3 a = Vec3 a a a+-- > instance Functor Vec3 where+-- >     fmap f (Vec3 x y z) = Vec3 (f x) (f y) (f z)+-- > instance Applicative Vec3 where+-- >     pure x = Vec3 x x x+-- >     liftA2 f (Vec3 p q r) (Vec3 x y z) = Vec3 (f p x) (f q y) (f r z)+-- > instance Foldable Vec3 where+-- >     foldr f z (Vec3 a b c) = f a (f b (f c z))+-- >     foldMap f (Vec3 a b c) = f a <> f b <> f c+-- > instance Traversable Vec3 where+-- >     traverse f (Vec3 a b c) = Vec3 <$> f a <*> f b <*> f c+--+-- With the above definitions, @'sequenceA'@ (same as @'traverse' 'id'@) acts+-- as a /matrix transpose/ operation on @Vec2 (Vec3 Int)@ producing a+-- corresponding @Vec3 (Vec2 Int)@:+--+-- Let __@t = Vec2 (Vec3 1 2 3) (Vec3 4 5 6)@__ be our 'Traversable' structure,+-- and __@g = id :: Vec3 Int -> Vec3 Int@__ be the function used to traverse+-- __@t@__.  We then have:+--+-- > traverse g t = Vec2 <$> (Vec3 1 2 3) <*> (Vec3 4 5 6)+-- >              = Vec3 (Vec2 1 4) (Vec2 2 5) (Vec2 3 6)+--+-- This construction can be generalised from fixed width vectors to variable+-- length lists via 'Control.Applicative.ZipList'.  This gives a transpose+-- operation that works well for lists of equal length.  If some of the lists+-- are longer than others, they're truncated to the longest common length.+--+-- We've already looked at the standard 'Applicative' instance of @List@ for+-- which applying __@m@__ functions __@f1, f2, ..., fm@__ to __@n@__ input+-- values __@a1, a2, ..., an@__ produces __@m * n@__ outputs:+--+-- >>> :set -XTupleSections+-- >>> [("f1",), ("f2",), ("f3",)] <*> [1,2]+-- [("f1",1),("f1",2),("f2",1),("f2",2),("f3",1),("f3",2)]+--+-- There are however two more common ways to turn lists into 'Applicative'+-- control structures.  The first is via __@'Const' [a]@__, since lists are+-- monoids under concatenation, and we've already seen that __@'Const' m@__ is+-- an 'Applicative' functor when __@m@__ is a 'Monoid'.  The second, is based+-- on 'Data.List.zipWith', and is called 'Control.Applicative.ZipList':+--+-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- > newtype ZipList a = ZipList { getZipList :: [a] }+-- >     deriving (Show, Eq, ..., Functor)+-- >+-- > instance Applicative ZipList where+-- >     liftA2 f (ZipList xs) (ZipList ys) = ZipList $ zipWith f xs ys+-- >     pure x = repeat x+--+-- The 'liftA2' definition is clear enough, instead of applying __@f@__ to each+-- pair __@(x, y)@__ drawn independently from the __@xs@__ and __@ys@__, only+-- corresponding pairs at each index in the two lists are used.+--+-- The definition of 'pure' may look surprising, but it is needed to ensure+-- that the instance is lawful:+--+-- prop> liftA2 f (pure x) ys == fmap (f x) ys+--+-- Since __@ys@__ can have any length, we need to provide an infinite supply+-- of __@x@__ values in __@pure x@__ in order to have a value to pair with+-- each element __@y@__.+--+-- When 'Control.Applicative.ZipList' is the 'Applicative' functor used in the+-- [construction](#construction) of a traversal, a ZipList holding a partially+-- built structure with __@m@__ elements is combined with a component holding+-- __@n@__ elements via 'zipWith', resulting in __@min m n@__ outputs!+--+-- Therefore 'traverse' with __@g :: a -> ZipList b@__ will produce a @ZipList@+-- of __@t b@__ structures whose element count is the minimum length of the+-- ZipLists __@g a@__ with __@a@__ ranging over the elements of __@t@__.  When+-- __@t@__ is empty, the length is infinite (as expected for a minimum of an+-- empty set).+--+-- If the structure __@t@__ holds values of type __@ZipList a@__, we can use+-- the identity function __@id :: ZipList a -> ZipList a@__ for the first+-- argument of 'traverse':+--+-- > traverse (id :: ZipList a -> ZipList a) :: t (ZipList a) -> ZipList (t a)+--+-- The number of elements in the output @ZipList@ will be the length of the+-- shortest @ZipList@ element of __@t@__.  Each output __@t a@__ will have the+-- /same shape/ as the input __@t (ZipList a)@__, i.e. will share its number of+-- elements.+--+-- If we think of the elements of __@t (ZipList a)@__ as its rows, and the+-- elements of each individual @ZipList@ as the columns of that row, we see+-- that our traversal implements a /transpose/ operation swapping the rows+-- and columns of __@t@__, after first truncating all the rows to the column+-- count of the shortest one.+--+-- Since in fact __@'traverse' id@__ is just 'sequenceA' the above boils down+-- to a rather concise definition of /transpose/, with [coercion](#coercion)+-- used to implicitly wrap and unwrap the @ZipList@ @newtype@ as needed, giving+-- a function that operates on a list of lists:+--+-- >>> :set -XScopedTypeVariables+-- >>> import Control.Applicative (ZipList(..))+-- >>> import Data.Coerce (coerce)+-- >>>+-- >>> :{+-- >>> let+-- >>>     transpose :: forall a. [[a]] -> [[a]]+-- >>>     transpose = coerce (sequenceA :: [ZipList a] -> ZipList [a])+-- >>> in transpose [[1,2,3],[4..],[7..]]+-- >>> :}+-- [[1,4,7],[2,5,8],[3,6,9]]+--+-- The use of [coercion](#coercion) avoids the need to explicitly wrap and+-- unwrap __@ZipList@__ terms.++------------------++-- $laws+--+-- #laws#+-- A definition of 'traverse' must satisfy the following laws:+--+-- [Naturality]+--   @t . 'traverse' f = 'traverse' (t . f)@+--   for every applicative transformation @t@+--+-- [Identity]+--   @'traverse' 'Identity' = 'Identity'@+--+-- [Composition]+--   @'traverse' ('Data.Functor.Compose.Compose' . 'fmap' g . f)+--     = 'Data.Functor.Compose.Compose' . 'fmap' ('traverse' g) . 'traverse' f@+--+-- A definition of 'sequenceA' must satisfy the following laws:+--+-- [Naturality]+--   @t . 'sequenceA' = 'sequenceA' . 'fmap' t@+--   for every applicative transformation @t@+--+-- [Identity]+--   @'sequenceA' . 'fmap' 'Identity' = 'Identity'@+--+-- [Composition]+--   @'sequenceA' . 'fmap' 'Data.Functor.Compose.Compose'+--     = 'Data.Functor.Compose.Compose' . 'fmap' 'sequenceA' . 'sequenceA'@+--+-- where an /applicative transformation/ is a function+--+-- @t :: (Applicative f, Applicative g) => f a -> g a@+--+-- preserving the 'Applicative' operations, i.e.+--+-- @+-- t ('pure' x) = 'pure' x+-- t (f '<*>' x) = t f '<*>' t x+-- @+--+-- and the identity functor 'Identity' and composition functors+-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and+-- "Data.Functor.Compose".+--+-- A result of the naturality law is a purity law for 'traverse'+--+-- @'traverse' 'pure' = 'pure'@+--+-- The superclass instances should satisfy the following:+--+--  * In the 'Functor' instance, 'fmap' should be equivalent to traversal+--    with the identity applicative functor ('fmapDefault').+--+--  * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be+--    equivalent to traversal with a constant applicative functor+--    ('foldMapDefault').+--+-- Note: the 'Functor' superclass means that (in GHC) Traversable structures+-- cannot impose any constraints on the element type.  A Haskell implementation+-- that supports constrained functors could make it possible to define+-- constrained @Traversable@ structures.++------------------++-- $also+--+--  * \"The Essence of the Iterator Pattern\",+--    by Jeremy Gibbons and Bruno Oliveira,+--    in /Mathematically-Structured Functional Programming/, 2006, online at+--    <http://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/#iterator>.+--+--  * \"Applicative Programming with Effects\",+--    by Conor McBride and Ross Paterson,+--    /Journal of Functional Programming/ 18:1 (2008) 1-13, online at+--    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+--  * \"An Investigation of the Laws of Traversals\",+--    by Mauro Jaskelioff and Ondrej Rypacek,+--    in /Mathematically-Structured Functional Programming/, 2012, online at+--    <http://arxiv.org/pdf/1202.2919>.
+ src/Data/Tuple.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Tuple+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Functions associated with the tuple data types.+--++module Data.Tuple+    (Solo(..),+     getSolo,+     fst,+     snd,+     curry,+     uncurry,+     swap+     ) where++import GHC.Internal.Data.Tuple
+ src/Data/Type/Bool.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE Safe #-}++{-# LANGUAGE ExplicitNamespaces #-}++-- |+--+-- Module      :  Data.Type.Bool+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  not portable+--+-- Basic operations on type-level Booleans.+--+-- @since 4.7.0.0++module Data.Type.Bool+    (If,+     type (&&),+     type (||),+     Not+     ) where++import GHC.Internal.Data.Type.Bool
+ src/Data/Type/Coercion.hs view
@@ -0,0 +1,24 @@+-- |+--+-- Module      :  Data.Type.Coercion+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  not portable+--+-- Definition of representational equality ('Coercion').+--+-- @since 4.7.0.0++module Data.Type.Coercion+    (Coercion(..),+     coerceWith,+     gcoerceWith,+     sym,+     trans,+     repr,+     TestCoercion(..)+     ) where++import GHC.Internal.Data.Type.Coercion
+ src/Data/Type/Equality.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE Safe #-}++{-# LANGUAGE ExplicitNamespaces #-}++-- |+--+-- Module      :  Data.Type.Equality+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  not portable+--+-- Definition of propositional equality @(':~:')@. Pattern-matching on a variable+-- of type @(a ':~:' b)@ produces a proof that @a '~' b@.+--+-- @since 4.7.0.0++module Data.Type.Equality+    (-- *  The equality types+     type (~),+     type (~~),+     (:~:)(..),+     (:~~:)(..),+     -- *  Working with equality+     sym,+     trans,+     castWith,+     gcastWith,+     apply,+     inner,+     outer,+     -- *  Inferring equality from other types+     TestEquality(..),+     -- *  Boolean type-level equality+     type (==)+     ) where++import GHC.Internal.Data.Type.Equality
+ src/Data/Type/Ord.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Safe #-}++{-# LANGUAGE ExplicitNamespaces #-}++-- |+--+-- Module      :  Data.Type.Ord+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  not portable+--+-- Basic operations on type-level Orderings.+--+-- @since 4.16.0.0++module Data.Type.Ord+    (Compare,+     OrderingI(..),+     type (<=),+     type (<=?),+     type (>=),+     type (>=?),+     type (>),+     type (>?),+     type (<),+     type (<?),+     Max,+     Min,+     OrdCond+     ) where++import GHC.Internal.Data.Type.Ord
+ src/Data/Typeable.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Typeable+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The 'Typeable' class reifies types to some extent by associating type+-- representations to types. These type representations can be compared,+-- and one can in turn define a type-safe cast operation. To this end,+-- an unsafe cast is guarded by a test for type (representation)+-- equivalence. The module "Data.Dynamic" uses Typeable for an+-- implementation of dynamics. The module "Data.Data" uses Typeable+-- and type-safe cast (but not dynamics) to support the \"Scrap your+-- boilerplate\" style of generic programming.+--+-- == Compatibility Notes+--+-- Since GHC 8.2, GHC has supported type-indexed type representations.+-- "Data.Typeable" provides type representations which are qualified over this+-- index, providing an interface very similar to the "Typeable" notion seen in+-- previous releases. For the type-indexed interface, see "Type.Reflection".+--+-- Since GHC 7.10, all types automatically have 'Typeable' instances derived.+-- This is in contrast to previous releases where 'Typeable' had to be+-- explicitly derived using the @DeriveDataTypeable@ language extension.+--+-- Since GHC 7.8, 'Typeable' is poly-kinded. The changes required for this might+-- break some old programs involving 'Typeable'. More details on this, including+-- how to fix your code, can be found on the+-- <https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/poly-typeable PolyTypeable wiki page>+--++module Data.Typeable+    (-- *  The Typeable class+     Typeable,+     typeOf,+     typeRep,+     -- *  Propositional equality+     (:~:)(Refl),+     (:~~:)(HRefl),+     -- *  Type-safe cast+     cast,+     eqT,+     heqT,+     decT,+     hdecT,+     gcast,+     -- *  Generalized casts for higher-order kinds+     gcast1,+     gcast2,+     -- *  A canonical proxy type+     Proxy(..),+     -- *  Type representations+     TypeRep,+     rnfTypeRep,+     showsTypeRep,+     mkFunTy,+     -- *  Observing type representations+     funResultTy,+     splitTyConApp,+     typeRepArgs,+     typeRepTyCon,+     typeRepFingerprint,+     -- *  Type constructors+     TyCon,+     tyConPackage,+     tyConModule,+     tyConName,+     rnfTyCon,+     tyConFingerprint,+     -- *  For backwards compatibility+     typeOf1,+     typeOf2,+     typeOf3,+     typeOf4,+     typeOf5,+     typeOf6,+     typeOf7,+     trLiftedRep+     ) where++import GHC.Internal.Data.Typeable
+ src/Data/Unique.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Unique+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- An abstract interface to a unique symbol generator.+--++module Data.Unique+    (-- *  Unique objects+     Unique,+     newUnique,+     hashUnique+     ) where++import GHC.Internal.Data.Unique
+ src/Data/Version.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Data.Version+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (local universal quantification in ReadP)+--+-- A general API for representation and manipulation of versions.+--+-- Versioning schemes are many and varied, so the version+-- representation provided by this library is intended to be a+-- compromise between complete generality, where almost no common+-- functionality could reasonably be provided, and fixing a particular+-- versioning scheme, which would probably be too restrictive.+--+-- So the approach taken here is to provide a representation which+-- subsumes many of the versioning schemes commonly in use, and we+-- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String'+-- which will be appropriate for some applications, but not all.+--++module Data.Version (+        -- * The @Version@ type+        Version(..),+        -- * A concrete representation of @Version@+        showVersion, parseVersion,+        -- * Constructor function+        makeVersion+      ) where++import GHC.Internal.Data.Version
+ src/Data/Void.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Copyright   :  (C) 2008-2014 Edward Kmett+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- A logically uninhabited data type, used to indicate that a given+-- term should not exist.+--+-- @since 4.8.0.0++module Data.Void+    (Void,+     absurd,+     vacuous+     ) where++import GHC.Internal.Data.Void
+ src/Data/Word.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Data.Word+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Unsigned integer types.+--++module Data.Word+    (-- *  Unsigned integral types+     Word,+     Word8,+     Word16,+     Word32,+     Word64,+     -- *  byte swapping+     byteSwap16,+     byteSwap32,+     byteSwap64,+     -- *  bit reversal+     bitReverse8,+     bitReverse16,+     bitReverse32,+     bitReverse64,+     -- *  Notes+     -- $notes+     ) where++import GHC.Internal.Word++{- $notes++* All arithmetic is performed modulo 2^n, where n is the number of+  bits in the type.  One non-obvious consequence of this is that 'Prelude.negate'+  should /not/ raise an error on negative arguments.++* For coercing between any two integer types, use+  'Prelude.fromIntegral', which is specialized for all the+  common cases so should be fast enough.  Coercing word types to and+  from integer types preserves representation, not sign.++* An unbounded size unsigned integer type is available with+  'Numeric.Natural.Natural'.++* The rules that hold for 'Prelude.Enum' instances over a bounded type+  such as 'Prelude.Int' (see the section of the Haskell report dealing+  with arithmetic sequences) also hold for the 'Prelude.Enum' instances+  over the various 'Word' types defined here.++* Right and left shifts by amounts greater than or equal to the width+  of the type result in a zero result.  This is contrary to the+  behaviour in C, which is undefined; a common interpretation is to+  truncate the shift count to the width of the type, for example @1 \<\<+  32 == 1@ in some C implementations.+-}
+ src/Debug/Trace.hs view
@@ -0,0 +1,95 @@+-- |+--+-- Module      :  Debug.Trace+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for tracing and monitoring execution.+--+-- These can be useful for investigating bugs or performance problems.+-- They should /not/ be used in production code.+--++module Debug.Trace+    (-- * Tracing+     -- $tracing+     trace,+     traceId,+     traceShow,+     traceShowId,+     traceWith,+     traceShowWith,+     traceStack,+     traceIO,+     traceM,+     traceShowM,+     putTraceMsg,++     -- * Eventlog tracing+     -- $eventlog_tracing+     traceEvent,+     traceEventWith,+     traceEventIO,+     flushEventLog,++     -- * Execution phase markers+     -- $markers+     traceMarker,+     traceMarkerIO,+     ) where++import GHC.Internal.Debug.Trace++-- $setup+-- >>> import Prelude++-- $tracing+--+-- The 'trace', 'traceShow' and 'traceIO' functions print messages to an output+-- stream. They are intended for \"printf debugging\", that is: tracing the flow+-- of execution and printing interesting values.+--+-- All these functions evaluate the message completely before printing+-- it; so if the message is not fully defined, none of it will be+-- printed.+--+-- The usual output stream is 'GHC.Internal.System.IO.stderr'. For Windows GUI applications+-- (that have no stderr) the output is directed to the Windows debug console.+-- Some implementations of these functions may decorate the string that\'s+-- output to indicate that you\'re tracing.++-- $eventlog_tracing+--+-- Eventlog tracing is a performance profiling system. These functions emit+-- extra events into the eventlog. In combination with eventlog profiling+-- tools these functions can be used for monitoring execution and+-- investigating performance problems.+--+-- Currently only GHC provides eventlog profiling, see the GHC user guide for+-- details on how to use it. These function exists for other Haskell+-- implementations but no events are emitted. Note that the string message is+-- always evaluated, whether or not profiling is available or enabled.++-- $markers+--+-- When looking at a profile for the execution of a program we often want to+-- be able to mark certain points or phases in the execution and see that+-- visually in the profile.+--+-- For example, a program might have several distinct phases with different+-- performance or resource behaviour in each phase. To properly interpret the+-- profile graph we really want to see when each phase starts and ends.+--+-- Markers let us do this: we can annotate the program to emit a marker at+-- an appropriate point during execution and then see that in a profile.+--+-- Currently this feature is only supported in GHC by the eventlog tracing+-- system, but in future it may also be supported by the heap profiling or+-- other profiling tools. These function exists for other Haskell+-- implementations but they have no effect. Note that the string message is+-- always evaluated, whether or not profiling is available or enabled.+
+ src/Foreign.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of data types, classes, and functions for interfacing+-- with another programming language.+--++module Foreign+        ( module Data.Bits+        , module Data.Int+        , module Data.Word+        , module Foreign.Ptr+        , module Foreign.ForeignPtr+        , module Foreign.StablePtr+        , module Foreign.Storable+        , module Foreign.Marshal+        ) where++import Data.Bits+import Data.Int+import Data.Word+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Foreign.Storable+import Foreign.Marshal
+ src/Foreign/C.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.C+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Bundles the C specific FFI library functionality+--++module Foreign.C+    (module Foreign.C.Types,+     module Foreign.C.String,+     module Foreign.C.Error+     ) where++import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error
+ src/Foreign/C/ConstPtr.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.C.ConstPtr+-- Copyright   :  (c) GHC Developers+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides typed @const@ pointers to foreign data. It is part+-- of the Foreign Function Interface (FFI).+--++module Foreign.C.ConstPtr+    (ConstPtr(..)+     ) where++import GHC.Internal.Foreign.C.ConstPtr
+ src/Foreign/C/Error.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.C.Error+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- C-specific Marshalling support: Handling of C \"errno\" error codes.+--++module Foreign.C.Error+    (-- *  Haskell representations of @errno@ values+     Errno(..),+     -- **  Common @errno@ symbols+     -- | Different operating systems and\/or C libraries often support+     -- different values of @errno@. This module defines the common values,+     -- but due to the open definition of 'Errno' users may add definitions+     -- which are not predefined.+     eOK,+     e2BIG,+     eACCES,+     eADDRINUSE,+     eADDRNOTAVAIL,+     eADV,+     eAFNOSUPPORT,+     eAGAIN,+     eALREADY,+     eBADF,+     eBADMSG,+     eBADRPC,+     eBUSY,+     eCHILD,+     eCOMM,+     eCONNABORTED,+     eCONNREFUSED,+     eCONNRESET,+     eDEADLK,+     eDESTADDRREQ,+     eDIRTY,+     eDOM,+     eDQUOT,+     eEXIST,+     eFAULT,+     eFBIG,+     eFTYPE,+     eHOSTDOWN,+     eHOSTUNREACH,+     eIDRM,+     eILSEQ,+     eINPROGRESS,+     eINTR,+     eINVAL,+     eIO,+     eISCONN,+     eISDIR,+     eLOOP,+     eMFILE,+     eMLINK,+     eMSGSIZE,+     eMULTIHOP,+     eNAMETOOLONG,+     eNETDOWN,+     eNETRESET,+     eNETUNREACH,+     eNFILE,+     eNOBUFS,+     eNODATA,+     eNODEV,+     eNOENT,+     eNOEXEC,+     eNOLCK,+     eNOLINK,+     eNOMEM,+     eNOMSG,+     eNONET,+     eNOPROTOOPT,+     eNOSPC,+     eNOSR,+     eNOSTR,+     eNOSYS,+     eNOTBLK,+     eNOTCONN,+     eNOTDIR,+     eNOTEMPTY,+     eNOTSOCK,+     eNOTSUP,+     eNOTTY,+     eNXIO,+     eOPNOTSUPP,+     ePERM,+     ePFNOSUPPORT,+     ePIPE,+     ePROCLIM,+     ePROCUNAVAIL,+     ePROGMISMATCH,+     ePROGUNAVAIL,+     ePROTO,+     ePROTONOSUPPORT,+     ePROTOTYPE,+     eRANGE,+     eREMCHG,+     eREMOTE,+     eROFS,+     eRPCMISMATCH,+     eRREMOTE,+     eSHUTDOWN,+     eSOCKTNOSUPPORT,+     eSPIPE,+     eSRCH,+     eSRMNT,+     eSTALE,+     eTIME,+     eTIMEDOUT,+     eTOOMANYREFS,+     eTXTBSY,+     eUSERS,+     eWOULDBLOCK,+     eXDEV,+     -- **  'Errno' functions+     isValidErrno,+     getErrno,+     resetErrno,+     errnoToIOError,+     throwErrno,+     -- **  Guards for IO operations that may fail+     throwErrnoIf,+     throwErrnoIf_,+     throwErrnoIfRetry,+     throwErrnoIfRetry_,+     throwErrnoIfMinus1,+     throwErrnoIfMinus1_,+     throwErrnoIfMinus1Retry,+     throwErrnoIfMinus1Retry_,+     throwErrnoIfNull,+     throwErrnoIfNullRetry,+     throwErrnoIfRetryMayBlock,+     throwErrnoIfRetryMayBlock_,+     throwErrnoIfMinus1RetryMayBlock,+     throwErrnoIfMinus1RetryMayBlock_,+     throwErrnoIfNullRetryMayBlock,+     throwErrnoPath,+     throwErrnoPathIf,+     throwErrnoPathIf_,+     throwErrnoPathIfNull,+     throwErrnoPathIfMinus1,+     throwErrnoPathIfMinus1_+     ) where++import GHC.Internal.Foreign.C.Error
+ src/Foreign/C/String.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  Foreign.C.String+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for primitive marshalling of C strings.+--+-- The marshalling converts each Haskell character, representing a Unicode+-- code point, to one or more bytes in a manner that, by default, is+-- determined by the current locale.  As a consequence, no guarantees+-- can be made about the relative length of a Haskell string and its+-- corresponding C string, and therefore all the marshalling routines+-- include memory allocation.  The translation between Unicode and the+-- encoding of the current locale may be lossy.+--++module Foreign.C.String (+  -- * C strings++  CString,+  CStringLen,++  -- ** Using a locale-dependent encoding++  -- | These functions are different from their @CAString@ counterparts+  -- in that they will use an encoding determined by the current locale,+  -- rather than always assuming ASCII.++  -- conversion of C strings into Haskell strings+  --+  peekCString,+  peekCStringLen,++  -- conversion of Haskell strings into C strings+  --+  newCString,+  newCStringLen,++  -- conversion of Haskell strings into C strings using temporary storage+  --+  withCString,+  withCStringLen,++  charIsRepresentable,++  -- ** Using 8-bit characters++  -- | These variants of the above functions are for use with C libraries+  -- that are ignorant of Unicode.  These functions should be used with+  -- care, as a loss of information can occur.++  castCharToCChar,+  castCCharToChar,++  castCharToCUChar,+  castCUCharToChar,+  castCharToCSChar,+  castCSCharToChar,++  peekCAString,+  peekCAStringLen,+  newCAString,+  newCAStringLen,+  withCAString,+  withCAStringLen,++  -- * C wide strings++  -- | These variants of the above functions are for use with C libraries+  -- that encode Unicode using the C @wchar_t@ type in a system-dependent+  -- way.  The only encodings supported are+  --+  -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or+  --+  -- * UTF-16 (as used on Windows systems).++  CWString,+  CWStringLen,++  peekCWString,+  peekCWStringLen,+  newCWString,+  newCWStringLen,+  withCWString,+  withCWStringLen,++  ) where++import GHC.Internal.Foreign.C.String
+ src/Foreign/C/Types.hs view
@@ -0,0 +1,84 @@+-- |+--+-- Module      :  Foreign.C.Types+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Mapping of C types to corresponding Haskell types.+--++module Foreign.C.Types+    (-- *  Representations of C types+     -- $ctypes+     -- **  #platform# Platform differences+     -- |  This module contains platform specific information about types.+     -- __/As such, the types presented on this page reflect the/__+     -- __/platform on which the documentation was generated and may/__+     -- __/not coincide with the types on your platform./__+     -- **  Integral types+     -- |  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', 'Data.Typeable.Typeable',+     -- 'Storable', 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral'+     -- and 'Bits'.+     CChar(..),+     CSChar(..),+     CUChar(..),+     CShort(..),+     CUShort(..),+     CInt(..),+     CUInt(..),+     CLong(..),+     CULong(..),+     CPtrdiff(..),+     CSize(..),+     CWchar(..),+     CSigAtomic(..),+     CLLong(..),+     CULLong(..),+     CBool(..),+     CIntPtr(..),+     CUIntPtr(..),+     CIntMax(..),+     CUIntMax(..),+     -- **  Numeric types+     -- |  These types are represented as @newtype@s of basic+     -- foreign types, and are instances of+     -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',+     -- 'Prelude.Show', 'Prelude.Enum', 'Data.Typeable.Typeable' and+     -- 'Storable'.+     CClock(..),+     CTime(..),+     CUSeconds(..),+     CSUSeconds(..),+     -- |  To convert 'CTime' to 'Data.Time.UTCTime', use the following:+     --+     -- > \t -> posixSecondsToUTCTime (realToFrac t :: POSIXTime)++     -- **  Floating types+     -- |  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', 'Data.Typeable.Typeable', 'Storable',+     -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',+     -- 'Prelude.RealFrac' and 'Prelude.RealFloat'. That does mean+     -- that `CFloat`'s (respectively `CDouble`'s) instances of+     -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num' and+     -- 'Prelude.Fractional' are as badly behaved as `Prelude.Float`'s+     -- (respectively `Prelude.Double`'s).+     CFloat(..),+     CDouble(..),+     -- XXX GHC doesn't support CLDouble yet+     -- , CLDouble(..)+     -- **  Other types+     CFile,+     CFpos,+     CJmpBuf+     ) where++import GHC.Internal.Foreign.C.Types
+ src/Foreign/Concurrent.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Concurrent+-- Copyright   :  (c) The University of Glasgow 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires concurrency)+--+-- FFI datatypes and operations that use or require concurrency (GHC only).+--++module Foreign.Concurrent+    (-- *  Concurrency-based 'ForeignPtr' operations+     -- |  These functions generalize their namesakes in the portable+     -- "Foreign.ForeignPtr" module by allowing arbitrary 'IO' actions+     -- as finalizers.  These finalizers necessarily run in a separate+     -- thread, cf. /Destructors, Finalizers and Synchronization/,+     -- by Hans Boehm, /POPL/, 2003.+     newForeignPtr,+     addForeignPtrFinalizer+     ) where++import GHC.Internal.Foreign.Concurrent
+ src/Foreign/ForeignPtr.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.ForeignPtr+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'ForeignPtr' type and operations.  This module is part of the+-- Foreign Function Interface (FFI) and will usually be imported via+-- the "Foreign" module.+--+-- For non-portable support of Haskell finalizers, see the+-- "Foreign.Concurrent" module.+--++module Foreign.ForeignPtr+    (-- *  Finalised data pointers+     ForeignPtr,+     FinalizerPtr,+     FinalizerEnvPtr,+     -- **  Basic operations+     newForeignPtr,+     newForeignPtr_,+     addForeignPtrFinalizer,+     newForeignPtrEnv,+     addForeignPtrFinalizerEnv,+     withForeignPtr,+     finalizeForeignPtr,+     -- **  Low-level operations+     touchForeignPtr,+     castForeignPtr,+     plusForeignPtr,+     -- **  Allocating managed memory+     mallocForeignPtr,+     mallocForeignPtrBytes,+     mallocForeignPtrArray,+     mallocForeignPtrArray0+     ) where++import GHC.Internal.Foreign.ForeignPtr
+ src/Foreign/ForeignPtr/Safe.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE Trustworthy #-}++-- |+--+-- Module      :  Foreign.ForeignPtr.Safe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'ForeignPtr' type and operations.  This module is part of the+-- Foreign Function Interface (FFI) and will usually be imported via+-- the "Foreign" module.+--+-- Safe API Only.+--++module Foreign.ForeignPtr.Safe+    {-# DEPRECATED "Safe is now the default, please use GHC.Internal.Foreign.ForeignPtr instead" #-}+    (-- *  Finalised data pointers+     ForeignPtr,+     FinalizerPtr,+     FinalizerEnvPtr,+     -- **  Basic operations+     newForeignPtr,+     newForeignPtr_,+     addForeignPtrFinalizer,+     newForeignPtrEnv,+     addForeignPtrFinalizerEnv,+     withForeignPtr,+     finalizeForeignPtr,+     -- **  Low-level operations+     touchForeignPtr,+     castForeignPtr,+     -- **  Allocating managed memory+     mallocForeignPtr,+     mallocForeignPtrBytes,+     mallocForeignPtrArray,+     mallocForeignPtrArray0+     ) where++import GHC.Internal.Foreign.ForeignPtr.Imp
+ src/Foreign/ForeignPtr/Unsafe.hs view
@@ -0,0 +1,23 @@+-- |+--+-- Module      :  Foreign.ForeignPtr.Unsafe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'ForeignPtr' type and operations.  This module is part of the+-- Foreign Function Interface (FFI) and will usually be imported via+-- the "Foreign" module.+--+-- Unsafe API Only.+--++module Foreign.ForeignPtr.Unsafe+    (-- **  Unsafe low-level operations+     unsafeForeignPtrToPtr+     ) where++import GHC.Internal.Foreign.ForeignPtr.Unsafe
+ src/Foreign/Marshal.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal+-- Copyright   :  (c) The FFI task force 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support+--++module Foreign.Marshal+    (-- |  The module "Foreign.Marshal.Safe" re-exports the other modules in the+     -- @Foreign.Marshal@ hierarchy (except for @Foreign.Marshal.Unsafe@):+     module Foreign.Marshal.Alloc,+     module Foreign.Marshal.Array,+     module Foreign.Marshal.Error,+     module Foreign.Marshal.Pool,+     module Foreign.Marshal.Utils+     ) where++import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Error+import Foreign.Marshal.Pool+import Foreign.Marshal.Utils
+ src/Foreign/Marshal/Alloc.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal.Alloc+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The module "Foreign.Marshal.Alloc" provides operations to allocate and+-- deallocate blocks of raw memory (i.e., unstructured chunks of memory+-- outside of the area maintained by the Haskell storage manager).  These+-- memory blocks are commonly used to pass compound data structures to+-- foreign functions or to provide space in which compound result values+-- are obtained from foreign functions.+--+-- If any of the allocation functions fails, an exception is thrown.+-- In some cases, memory exhaustion may mean the process is terminated.+-- If 'free' or 'reallocBytes' is applied to a memory area+-- that has been allocated with 'alloca' or 'allocaBytes', the+-- behaviour is undefined.  Any further access to memory areas allocated with+-- 'alloca' or 'allocaBytes', after the computation that was passed to+-- the allocation function has terminated, leads to undefined behaviour.  Any+-- further access to the memory area referenced by a pointer passed to+-- 'realloc', 'reallocBytes', or 'free' entails undefined+-- behaviour.+--+-- All storage allocated by functions that allocate based on a /size in bytes/+-- must be sufficiently aligned for any of the basic foreign types+-- that fits into the newly allocated storage. All storage allocated by+-- functions that allocate based on a specific type must be sufficiently+-- aligned for that type. Array allocation routines need to obey the same+-- alignment constraints for each array element.+--+-- The underlying implementation is wrapping the @<stdlib.h>@+-- @malloc@, @realloc@, and @free@.+-- In other words it should be safe to allocate using C-@malloc@,+-- and free memory with 'free' from this module.+--++module Foreign.Marshal.Alloc+    (-- *  Memory allocation+     -- **  Local allocation+     alloca,+     allocaBytes,+     allocaBytesAligned,+     -- **  Dynamic allocation+     malloc,+     mallocBytes,+     calloc,+     callocBytes,+     realloc,+     reallocBytes,+     free,+     finalizerFree+     ) where++import GHC.Internal.Foreign.Marshal.Alloc
+ src/Foreign/Marshal/Array.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal.Array+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support: routines allocating, storing, and retrieving Haskell+-- lists that are represented as arrays in the foreign language+--++module Foreign.Marshal.Array+    (-- *  Marshalling arrays+     -- **  Allocation+     mallocArray,+     mallocArray0,+     allocaArray,+     allocaArray0,+     reallocArray,+     reallocArray0,+     callocArray,+     callocArray0,+     -- **  Marshalling+     peekArray,+     peekArray0,+     pokeArray,+     pokeArray0,+     -- **  Combined allocation and marshalling+     newArray,+     newArray0,+     withArray,+     withArray0,+     withArrayLen,+     withArrayLen0,+     -- **  Copying+     -- |  (argument order: destination, source)+     copyArray,+     moveArray,+     -- **  Finding the length+     lengthArray0,+     -- **  Indexing+     advancePtr+     ) where++import GHC.Internal.Foreign.Marshal.Array
+ src/Foreign/Marshal/Error.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal.Error+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Routines for testing return values and raising a 'userError' exception+-- in case of values indicating an error state.+--++module Foreign.Marshal.Error+    (throwIf,+     throwIf_,+     throwIfNeg,+     throwIfNeg_,+     throwIfNull,+     void+     ) where++import GHC.Internal.Foreign.Marshal.Error
+ src/Foreign/Marshal/Pool.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal.Pool+-- Copyright   :  (c) Sven Panne 2002-2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  sven.panne@aedion.de+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains support for pooled memory management. Under this scheme,+-- (re-)allocations belong to a given pool, and everything in a pool is+-- deallocated when the pool itself is deallocated. This is useful when+-- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation+-- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'+-- and 'free' are too awkward.+--++module Foreign.Marshal.Pool+    (-- *  Pool management+     Pool,+     newPool,+     freePool,+     withPool,+     -- *  (Re-)Allocation within a pool+     pooledMalloc,+     pooledMallocBytes,+     pooledRealloc,+     pooledReallocBytes,+     pooledMallocArray,+     pooledMallocArray0,+     pooledReallocArray,+     pooledReallocArray0,+     -- *  Combined allocation and marshalling+     pooledNew,+     pooledNewArray,+     pooledNewArray0+     ) where++import GHC.Internal.Foreign.Marshal.Pool
+ src/Foreign/Marshal/Safe.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal.Safe+-- Copyright   :  (c) The FFI task force 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support+--+-- Safe API Only.+--++module Foreign.Marshal.Safe+    (-- |  The module "Foreign.Marshal.Safe" re-exports the other modules in the+     -- @Foreign.Marshal@ hierarchy:+     module Foreign.Marshal.Alloc,+     module Foreign.Marshal.Array,+     module Foreign.Marshal.Error,+     module Foreign.Marshal.Pool,+     module Foreign.Marshal.Utils+     ) where++import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Error+import Foreign.Marshal.Pool+import Foreign.Marshal.Utils
+ src/Foreign/Marshal/Unsafe.hs view
@@ -0,0 +1,19 @@+-- |+--+-- Module      :  Foreign.Marshal.Unsafe+-- Copyright   :  (c) The FFI task force 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Marshalling support. Unsafe API.+--++module Foreign.Marshal.Unsafe+    (-- *  Unsafe functions+     unsafeLocalState+     ) where++import GHC.Internal.Foreign.Marshal.Unsafe
+ src/Foreign/Marshal/Utils.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Marshal.Utils+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for primitive marshaling+--++module Foreign.Marshal.Utils+    (-- *  General marshalling utilities+     -- **  Combined allocation and marshalling+     with,+     new,+     -- **  Marshalling of Boolean values (non-zero corresponds to 'True')+     fromBool,+     toBool,+     -- **  Marshalling of Maybe values+     maybeNew,+     maybeWith,+     maybePeek,+     -- **  Marshalling lists of storable objects+     withMany,+     -- **  Haskellish interface to memcpy and memmove+     -- |  (argument order: destination, source)++     copyBytes,+     moveBytes,+     -- **  Filling up memory area with required values+     fillBytes+     ) where++import GHC.Internal.Foreign.Marshal.Utils
+ src/Foreign/Ptr.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Ptr+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides typed pointers to foreign data.  It is part+-- of the Foreign Function Interface (FFI) and will normally be+-- imported via the "Foreign" module.+--++module Foreign.Ptr+    (-- *  Data pointers+     Ptr,+     nullPtr,+     castPtr,+     plusPtr,+     alignPtr,+     minusPtr,+     -- *  Function pointers+     FunPtr,+     nullFunPtr,+     castFunPtr,+     castFunPtrToPtr,+     castPtrToFunPtr,+     freeHaskellFunPtr,+     -- *  Integral types with lossless conversion to and from pointers+     IntPtr(..),+     ptrToIntPtr,+     intPtrToPtr,+     WordPtr(..),+     ptrToWordPtr,+     wordPtrToPtr+     ) where++import GHC.Internal.Foreign.Ptr
+ src/Foreign/Safe.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Safe+-- Copyright   :  (c) The FFI task force 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of data types, classes, and functions for interfacing+-- with another programming language.+--+-- Safe API Only.+--++module Foreign.Safe {-# DEPRECATED "Safe is now the default, please use Foreign instead" #-}+    (module Data.Bits,+     module Data.Int,+     module Data.Word,+     module Foreign.Ptr,+     module Foreign.ForeignPtr,+     module Foreign.StablePtr,+     module Foreign.Storable,+     module Foreign.Marshal+     ) where++import Data.Bits+import Data.Int+import Data.Word+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Foreign.Storable+import Foreign.Marshal+
+ src/Foreign/StablePtr.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.StablePtr+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- This module is part of the Foreign Function Interface (FFI) and will usually+-- be imported via the module "Foreign".+--++module Foreign.StablePtr+    (-- *  Stable references to Haskell values+     StablePtr,+     newStablePtr,+     deRefStablePtr,+     freeStablePtr,+     castStablePtrToPtr,+     castPtrToStablePtr,+     -- **  The C-side interface+     -- $cinterface+     ) where++import GHC.Internal.Foreign.StablePtr++-- $cinterface+--+-- The following definition is available to C programs inter-operating with+-- Haskell code when including the header @HsFFI.h@.+--+-- > typedef void *HsStablePtr;  /* C representation of a StablePtr */+--+-- Note that no assumptions may be made about the values representing stable+-- pointers.  In fact, they need not even be valid memory addresses.  The only+-- guarantee provided is that if they are passed back to Haskell land, the+-- function 'deRefStablePtr' will be able to reconstruct the+-- Haskell value referred to by the stable pointer.+
+ src/Foreign/Storable.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Foreign.Storable+-- Copyright   :  (c) The FFI task force 2001+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The module "Foreign.Storable" provides most elementary support for+-- marshalling and is part of the language-independent portion of the+-- Foreign Function Interface (FFI), and will normally be imported via+-- the "Foreign" module.+--++module Foreign.Storable+    (Storable(sizeOf, alignment, peekElemOff, pokeElemOff, peekByteOff, pokeByteOff, peek, poke)+     ) where++import GHC.Internal.Foreign.Storable
+ src/GHC/Arr.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Arr+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC\'s array implementation.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.Arr+    (Ix(..),+     Array(..),+     STArray(..),+     arrEleBottom,+     array,+     listArray,+     (!),+     safeRangeSize,+     negRange,+     safeIndex,+     badSafeIndex,+     bounds,+     numElements,+     numElementsSTArray,+     indices,+     elems,+     assocs,+     accumArray,+     adjust,+     (//),+     accum,+     amap,+     ixmap,+     eqArray,+     cmpArray,+     cmpIntArray,+     newSTArray,+     boundsSTArray,+     readSTArray,+     writeSTArray,+     freezeSTArray,+     thawSTArray,+     foldlElems,+     foldlElems',+     foldl1Elems,+     foldrElems,+     foldrElems',+     foldr1Elems,+     -- *  Unsafe operations+     fill,+     done,+     unsafeArray,+     unsafeArray',+     lessSafeIndex,+     unsafeAt,+     unsafeReplace,+     unsafeAccumArray,+     unsafeAccumArray',+     unsafeAccum,+     unsafeReadSTArray,+     unsafeWriteSTArray,+     unsafeFreezeSTArray,+     unsafeThawSTArray+     ) where++import GHC.Internal.Arr
+ src/GHC/ArrayArray.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE Safe #-}++{-# LANGUAGE MagicHash #-}++-- |+--+-- Module      :  GHC.ArrayArray+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Legacy interface for arrays of arrays.+-- Deprecated, because the 'Array#' type can now store arrays directly.+-- Consider simply using 'Array#' instead of 'ArrayArray#'.+--+-- Use GHC.Exts instead of importing this module directly.+--++module GHC.ArrayArray+    (ArrayArray#(..),+     MutableArrayArray#(..),+     newArrayArray#,+     unsafeFreezeArrayArray#,+     sizeofArrayArray#,+     sizeofMutableArrayArray#,+     indexByteArrayArray#,+     indexArrayArrayArray#,+     readByteArrayArray#,+     readMutableByteArrayArray#,+     readArrayArrayArray#,+     readMutableArrayArrayArray#,+     writeByteArrayArray#,+     writeMutableByteArrayArray#,+     writeArrayArrayArray#,+     writeMutableArrayArrayArray#,+     copyArrayArray#,+     copyMutableArrayArray#,+     sameArrayArray#,+     sameMutableArrayArray#+     ) where++import GHC.Internal.ArrayArray
+ src/GHC/Base.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Base+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic data types and classes.+--++-- N.B. This is a legacy module which we would at some point like to+-- deprecate and drop from `base`. In short, everything found here is+-- better imported from elsewhere. Until we have done so we prefer to+-- keep the export list as specific as possible (e.g. avoiding module+-- exports) to avoid changes in `ghc-internal` inadvertently+-- compromising the stability of this interface.++module GHC.Base+    ( module GHC.Types+    , module GHC.Prim+    , module GHC.Prim.Ext+    , module GHC.Prim.PtrEq+    , module GHC.Internal.Err+    , module GHC.Internal.Maybe++      -- * Equality and ordering+    , IP(..)+    , Eq(..)+    , Ord(..)+      -- ** Monomorphic equality operators+    , eqInt, neInt+    , eqWord, neWord+    , eqChar, neChar+    , eqFloat, eqDouble+    , gtInt, geInt, leInt, ltInt, compareInt, compareInt#+    , gtWord, geWord, leWord, ltWord, compareWord, compareWord#++      -- * C Strings+    , unpackCString#, unpackAppendCString#, unpackFoldrCString#+    , cstringLength#+    , unpackCStringUtf8#, unpackAppendCStringUtf8#, unpackFoldrCStringUtf8#+    , unpackNBytes#++      -- * Magic combinators+    , inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..)+    , WithDict(withDict)++      -- * Functions over 'Bool'+    , (&&), (||), not++      -- Void+    , Void+    , absurd+    , vacuous++      -- * Semigroup/Monoid+    , Semigroup(..)+    , Monoid(..)++      -- * Functors+    , Functor(..)+    , Applicative(..)+    , (<**>)+    , liftA+    , liftA3+    , join+    , Monad(..)+    , (=<<)+    , when+    , sequence+    , mapM+    , liftM+    , liftM2+    , liftM3+    , liftM4+    , liftM5+    , ap+    , Alternative(..)+    , MonadPlus(..)++      -- Lists+    , NonEmpty(..)+    , foldr+    , build+    , augment+    , map+    , mapFB+    , (++)+    , String+    , unsafeChr+    , ord+    , eqString+    , minInt, maxInt++      -- * Miscellanea+    , otherwise+    , id+    , assert+    , breakpoint+    , breakpointCond+    , Opaque(..)+    , const+    , (.)+    , flip+    , ($)+    , ($!)+    , until+    , asTypeOf++      -- * IO+    , returnIO+    , bindIO+    , thenIO+    , failIO+    , unIO++      -- * Low-level integer utilities+    , getTag+    , quotInt+    , remInt+    , divInt+    , modInt+    , quotRemInt+    , divModInt+    , shift_mask+    , shiftL#+    , shiftRL#+    , iShiftL#+    , iShiftRA#+    , iShiftRL#+    , divInt#, divInt8#, divInt16#, divInt32#+    , modInt#, modInt8#, modInt16#, modInt32#+    , divModInt#, divModInt8#, divModInt16#, divModInt32#+    ) where++import GHC.Internal.Base hiding ( NonEmpty(..) )+import GHC.Internal.Data.NonEmpty ( NonEmpty(..) )+import GHC.Prim hiding+  (+  -- Hide dataToTag# ops because they are expected to break for+  -- GHC-internal reasons in the near future, and shouldn't+  -- be exposed from base+    dataToTagSmall#, dataToTagLarge#+  -- whereFrom# is similarly internal.+  , whereFrom#+  , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned#+  -- Don't re-export vector FMA instructions+  , fmaddFloatX4#+  , fmsubFloatX4#+  , fnmaddFloatX4#+  , fnmsubFloatX4#+  , fmaddFloatX8#+  , fmsubFloatX8#+  , fnmaddFloatX8#+  , fnmsubFloatX8#+  , fmaddFloatX16#+  , fmsubFloatX16#+  , fnmaddFloatX16#+  , fnmsubFloatX16#+  , fmaddDoubleX2#+  , fmsubDoubleX2#+  , fnmaddDoubleX2#+  , fnmsubDoubleX2#+  , fmaddDoubleX4#+  , fmsubDoubleX4#+  , fnmaddDoubleX4#+  , fnmsubDoubleX4#+  , fmaddDoubleX8#+  , fmsubDoubleX8#+  , fnmaddDoubleX8#+  , fnmsubDoubleX8#+  -- Don't re-export SIMD shuffle primops+  , shuffleDoubleX2#+  , shuffleDoubleX4#+  , shuffleDoubleX8#+  , shuffleFloatX16#+  , shuffleFloatX4#+  , shuffleFloatX8#+  , shuffleInt16X16#+  , shuffleInt16X32#+  , shuffleInt16X8#+  , shuffleInt32X16#+  , shuffleInt32X4#+  , shuffleInt32X8#+  , shuffleInt64X2#+  , shuffleInt64X4#+  , shuffleInt64X8#+  , shuffleInt8X16#+  , shuffleInt8X32#+  , shuffleInt8X64#+  , shuffleWord16X16#+  , shuffleWord16X32#+  , shuffleWord16X8#+  , shuffleWord32X16#+  , shuffleWord32X4#+  , shuffleWord32X8#+  , shuffleWord64X2#+  , shuffleWord64X4#+  , shuffleWord64X8#+  , shuffleWord8X16#+  , shuffleWord8X32#+  , shuffleWord8X64#+  -- Don't re-export min/max primops+  , maxDouble#+  , maxDoubleX2#+  , maxDoubleX4#+  , maxDoubleX8#+  , maxFloat#+  , maxFloatX16#+  , maxFloatX4#+  , maxFloatX8#+  , maxInt16X16#+  , maxInt16X32#+  , maxInt16X8#+  , maxInt32X16#+  , maxInt32X4#+  , maxInt32X8#+  , maxInt64X2#+  , maxInt64X4#+  , maxInt64X8#+  , maxInt8X16#+  , maxInt8X32#+  , maxInt8X64#+  , maxWord16X16#+  , maxWord16X32#+  , maxWord16X8#+  , maxWord32X16#+  , maxWord32X4#+  , maxWord32X8#+  , maxWord64X2#+  , maxWord64X4#+  , maxWord64X8#+  , maxWord8X16#+  , maxWord8X32#+  , maxWord8X64#+  , minDouble#+  , minDoubleX2#+  , minDoubleX4#+  , minDoubleX8#+  , minFloat#+  , minFloatX16#+  , minFloatX4#+  , minFloatX8#+  , minInt16X16#+  , minInt16X32#+  , minInt16X8#+  , minInt32X16#+  , minInt32X4#+  , minInt32X8#+  , minInt64X2#+  , minInt64X4#+  , minInt64X8#+  , minInt8X16#+  , minInt8X32#+  , minInt8X64#+  , minWord16X16#+  , minWord16X32#+  , minWord16X8#+  , minWord32X16#+  , minWord32X4#+  , minWord32X8#+  , minWord64X2#+  , minWord64X4#+  , minWord64X8#+  , minWord8X16#+  , minWord8X32#+  , minWord8X64#+  )++import GHC.Prim.Ext+import GHC.Prim.PtrEq+import GHC.Internal.Err+import GHC.Internal.IO (seq#)+import GHC.Internal.Maybe+import GHC.Types hiding (+  Unit#,+  Solo#(..),+  Tuple0#,+  Tuple1#,+  Tuple2#,+  Tuple3#,+  Tuple4#,+  Tuple5#,+  Tuple6#,+  Tuple7#,+  Tuple8#,+  Tuple9#,+  Tuple10#,+  Tuple11#,+  Tuple12#,+  Tuple13#,+  Tuple14#,+  Tuple15#,+  Tuple16#,+  Tuple17#,+  Tuple18#,+  Tuple19#,+  Tuple20#,+  Tuple21#,+  Tuple22#,+  Tuple23#,+  Tuple24#,+  Tuple25#,+  Tuple26#,+  Tuple27#,+  Tuple28#,+  Tuple29#,+  Tuple30#,+  Tuple31#,+  Tuple32#,+  Tuple33#,+  Tuple34#,+  Tuple35#,+  Tuple36#,+  Tuple37#,+  Tuple38#,+  Tuple39#,+  Tuple40#,+  Tuple41#,+  Tuple42#,+  Tuple43#,+  Tuple44#,+  Tuple45#,+  Tuple46#,+  Tuple47#,+  Tuple48#,+  Tuple49#,+  Tuple50#,+  Tuple51#,+  Tuple52#,+  Tuple53#,+  Tuple54#,+  Tuple55#,+  Tuple56#,+  Tuple57#,+  Tuple58#,+  Tuple59#,+  Tuple60#,+  Tuple61#,+  Tuple62#,+  Tuple63#,+  Tuple64#,+  Sum2#,+  Sum3#,+  Sum4#,+  Sum5#,+  Sum6#,+  Sum7#,+  Sum8#,+  Sum9#,+  Sum10#,+  Sum11#,+  Sum12#,+  Sum13#,+  Sum14#,+  Sum15#,+  Sum16#,+  Sum17#,+  Sum18#,+  Sum19#,+  Sum20#,+  Sum21#,+  Sum22#,+  Sum23#,+  Sum24#,+  Sum25#,+  Sum26#,+  Sum27#,+  Sum28#,+  Sum29#,+  Sum30#,+  Sum31#,+  Sum32#,+  Sum33#,+  Sum34#,+  Sum35#,+  Sum36#,+  Sum37#,+  Sum38#,+  Sum39#,+  Sum40#,+  Sum41#,+  Sum42#,+  Sum43#,+  Sum44#,+  Sum45#,+  Sum46#,+  Sum47#,+  Sum48#,+  Sum49#,+  Sum50#,+  Sum51#,+  Sum52#,+  Sum53#,+  Sum54#,+  Sum55#,+  Sum56#,+  Sum57#,+  Sum58#,+  Sum59#,+  Sum60#,+  Sum61#,+  Sum62#,+  Sum63#,+  )
+ src/GHC/Bits.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Bits+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- This module defines bitwise operations for signed and unsigned+-- integers.  Instances of the class 'Bits' for the 'Int' and+-- 'Integer' types are available from this module, and instances for+-- explicitly sized integral types are available from the+-- "Data.Int" and "Data.Word" modules.+--++module GHC.Bits+    (Bits((.&.), (.|.), xor, complement, shift, rotate, zeroBits, bit, setBit, clearBit, complementBit, testBit, bitSizeMaybe, bitSize, isSigned, shiftL, shiftR, unsafeShiftL, unsafeShiftR, rotateL, rotateR, popCount),+     FiniteBits(finiteBitSize, countLeadingZeros, countTrailingZeros),+     bitDefault,+     testBitDefault,+     popCountDefault,+     toIntegralSized+     ) where++import GHC.Internal.Bits
+ src/GHC/ByteOrder.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.ByteOrder+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Target byte ordering.+--+-- @since 4.11.0.0++module GHC.ByteOrder+    (ByteOrder(..),+     targetByteOrder+     ) where++import GHC.Internal.ByteOrder
+ src/GHC/Char.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE Safe #-}++module GHC.Char+    (-- *  Utilities+     chr,+     -- *  Monomorphic equality operators+     -- |  See GHC.Classes#matching_overloaded_methods_in_rules+     eqChar,+     neChar+     ) where++import GHC.Internal.Char
+ src/GHC/Clock.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.Clock+-- License     :  BSD-style (see the file LICENSE in this distribution)+--+-- Stability   :  internal+-- Portability :  portable+--+-- System monotonic time.+--++module GHC.Clock+    ( getMonotonicTime+    , getMonotonicTimeNSec+    ) where++import GHC.Internal.Clock
+ src/GHC/Conc.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Conc+-- Copyright   :  (c) The University of Glasgow, 1994-2023+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic concurrency stuff.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--+-----------------------------------------------------------------------------++-- No: #hide, because bits of this module are exposed by the stm package.+-- However, we don't want this module to be the home location for the+-- bits it exports, we'd rather have Control.Concurrent and the other+-- higher level modules be the home.  Hence: #not-home++module GHC.Conc+        ( ThreadId(..)++        -- * Forking and suchlike+        , forkIO+        , forkIOWithUnmask+        , forkOn+        , forkOnWithUnmask+        , numCapabilities+        , getNumCapabilities+        , setNumCapabilities+        , getNumProcessors+        , numSparks+        , childHandler+        , myThreadId+        , killThread+        , throwTo+        , par+        , pseq+        , runSparks+        , yield+        , labelThread+        , mkWeakThreadId+        , listThreads++        , ThreadStatus(..), BlockReason(..)+        , threadStatus+        , threadCapability++        , newStablePtrPrimMVar, PrimMVar++        -- * Waiting+        , threadDelay+        , registerDelay+        , threadWaitRead+        , threadWaitWrite+        , threadWaitReadSTM+        , threadWaitWriteSTM+        , closeFdWith++        -- * Allocation counter and limit+        , setAllocationCounter+        , getAllocationCounter+        , enableAllocationLimit+        , disableAllocationLimit++        -- * TVars+        , STM(..)+        , atomically+        , retry+        , orElse+        , throwSTM+        , catchSTM+        , TVar(..)+        , newTVar+        , newTVarIO+        , readTVar+        , readTVarIO+        , writeTVar+        , unsafeIOToSTM++        -- * Miscellaneous+        , withMVar+#if defined(mingw32_HOST_OS)+        , asyncRead+        , asyncWrite+        , asyncDoProc++        , asyncReadBA+        , asyncWriteBA+#endif++#if !defined(mingw32_HOST_OS)+        , Signal, HandlerFun, setHandler, runHandlers+#endif++        , ensureIOManagerIsRunning+        , ioManagerCapabilitiesChanged++#if defined(mingw32_HOST_OS)+        , ConsoleEvent(..)+        , win32ConsoleHandler+        , toWin32ConsoleEvent+#endif+        , setUncaughtExceptionHandler+        , getUncaughtExceptionHandler++        , reportError, reportStackOverflow, reportHeapOverflow+        ) where++import GHC.Internal.Conc.IO+import GHC.Internal.Conc.Sync++#if !defined(mingw32_HOST_OS)+import GHC.Internal.Conc.Signal+#endif
+ src/GHC/Conc/IO.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Conc.IO+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic concurrency stuff.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.Conc.IO+    (ensureIOManagerIsRunning,+     ioManagerCapabilitiesChanged,+     interruptIOManager,+     -- *  Waiting+     threadDelay,+     registerDelay,+     threadWaitRead,+     threadWaitWrite,+     threadWaitReadSTM,+     threadWaitWriteSTM,+     closeFdWith+     ) where++import GHC.Internal.Conc.IO
+ src/GHC/Conc/POSIX.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Conc.POSIX+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Windows I/O manager+--+-- This is the I/O manager based on posix FDs for windows.+-- When using the winio manager these functions may not+-- be used as they will behave in unexpected ways.+--+-- TODO: This manager is currently the default. But we will eventually+-- switch to use winio instead.+--++module GHC.Conc.POSIX+       ( ensureIOManagerIsRunning+       , interruptIOManager++       -- * Waiting+       , threadDelay+       , registerDelay++       -- * Miscellaneous+       , asyncRead+       , asyncWrite+       , asyncDoProc++       , asyncReadBA+       , asyncWriteBA++       , module GHC.Internal.Event.Windows.ConsoleEvent+       ) where++import GHC.Internal.Conc.POSIX+import GHC.Internal.Event.Windows.ConsoleEvent
+ src/GHC/Conc/POSIX/Const.hs view
@@ -0,0 +1,5 @@+module GHC.Conc.POSIX.Const+    ( io_MANAGER_WAKEUP, io_MANAGER_DIE+    ) where++import GHC.Internal.Conc.POSIX.Const
+ src/GHC/Conc/Signal.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Safe #-}++module GHC.Conc.Signal+    (Signal,+     HandlerFun,+     setHandler,+     runHandlers,+     runHandlersPtr+     ) where++import GHC.Internal.Conc.Signal
+ src/GHC/Conc/Sync.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Conc.Sync+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Basic concurrency stuff.+--++module GHC.Conc.Sync+        (+        -- * Threads+          ThreadId(..)+        , fromThreadId+        , showThreadId+        , myThreadId+        , killThread+        , throwTo+        , yield+        , labelThread+        , labelThreadByteArray#+        , mkWeakThreadId+        -- ** Queries+        , listThreads+        , threadLabel+        , ThreadStatus(..), BlockReason(..)+        , threadStatus+        , threadCapability++        -- * Forking and suchlike+        , forkIO+        , forkIOWithUnmask+        , forkOn+        , forkOnWithUnmask++        -- * Capabilities+        , numCapabilities+        , getNumCapabilities+        , setNumCapabilities+        , getNumProcessors++        -- * Sparks+        , numSparks+        , childHandler+        , par+        , pseq+        , runSparks++        -- * PrimMVar+        , newStablePtrPrimMVar, PrimMVar++        -- * Allocation counter and quota+        , setAllocationCounter+        , getAllocationCounter+        , enableAllocationLimit+        , disableAllocationLimit++        -- * TVars+        , STM(..)+        , atomically+        , retry+        , orElse+        , throwSTM+        , catchSTM+        , TVar(..)+        , newTVar+        , newTVarIO+        , readTVar+        , readTVarIO+        , writeTVar+        , unsafeIOToSTM++        -- * Miscellaneous+        , withMVar+        , modifyMVar_++        , setUncaughtExceptionHandler+        , getUncaughtExceptionHandler++        , reportError, reportStackOverflow, reportHeapOverflow++        , sharedCAF+        ) where++import GHC.Internal.Conc.Sync
+ src/GHC/Conc/WinIO.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Conc.WinIO+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Windows I/O Completion Port interface to the one defined in+-- GHC.Event.Windows.+--+-- This module is an indirection to keep things in the same structure as before+-- but also to keep the new code where the actual I/O manager is.  As such it+-- just re-exports "GHC.Event.Windows.Thread"+--++module GHC.Conc.WinIO+       ( module GHC.Internal.Event.Windows.Thread ) where++import GHC.Internal.Event.Windows.Thread
+ src/GHC/Conc/Windows.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.Internal.Conc.Windows+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used+-- requests will be routed to different places.+--+--+module GHC.Conc.Windows++#if defined(javascript_HOST_ARCH)+       () where++#else+       ( ensureIOManagerIsRunning+       , interruptIOManager++       -- * Waiting+       , threadDelay+       , registerDelay++       -- * Miscellaneous+       , asyncRead+       , asyncWrite+       , asyncDoProc++       , asyncReadBA+       , asyncWriteBA++       -- * Console event handler+       , module GHC.Internal.Event.Windows.ConsoleEvent+       ) where++import GHC.Internal.Conc.Windows+import GHC.Internal.Event.Windows.ConsoleEvent++#endif
+ src/GHC/ConsoleHandler.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.ConsoleHandler+-- Copyright   :  (c) The University of Glasgow+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- NB. the contents of this module are only available on Windows.+--+-- Installing Win32 console handlers.+--++#if !defined(mingw32_HOST_OS)++module GHC.ConsoleHandler () where++-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import Prelude () -- for build ordering++#else++module GHC.ConsoleHandler+        ( Handler(..)+        , installHandler+        , ConsoleEvent(..)+        ) where++import GHC.Internal.ConsoleHandler++#endif+
+ src/GHC/Constants.hs view
@@ -0,0 +1,6 @@+-- TODO: Deprecate+module GHC.Constants where++-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Types () -- for build ordering+
+ src/GHC/Desugar.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+--+-- Module      :  GHC.Desugar+-- Copyright   :  (c) The University of Glasgow, 2007+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  deprecated (<https://github.com/haskell/core-libraries-committee/issues/216>)+-- Portability :  non-portable (GHC extensions)+--+-- Support code for desugaring in GHC+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--+-----------------------------------------------------------------------------++#if __GLASGOW_HASKELL >= 914+#error "GHC.Desugar should be removed in GHC 9.14"+#endif++module GHC.Desugar+  {-# DEPRECATED ["GHC.Desugar is deprecated and will be removed in GHC 9.14.", "(>>>) should be imported from Control.Arrow.", "AnnotationWrapper is internal to GHC and should not be used externally."] #-}+  ((>>>), AnnotationWrapper(..), toAnnotationWrapper) where++import GHC.Internal.Desugar
+ src/GHC/Encoding/UTF8.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE MagicHash #-}++-- |+--+-- Module      :  GHC.Encoding.UTF8+-- Copyright   :  (c) The University of Glasgow, 1994-2023+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--+-- Simple UTF-8 codecs supporting non-streaming encoding/decoding.+-- For encoding where codepoints may be broken across buffers,+-- see "GHC.IO.Encoding.UTF8".+--+-- This is one of several UTF-8 implementations provided by GHC; see Note+-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an+-- overview.+--++module GHC.Encoding.UTF8+    (-- *  Decoding single characters+     utf8DecodeCharAddr#,+     utf8DecodeCharPtr,+     utf8DecodeCharByteArray#,+     -- *  Decoding strings+     utf8DecodeByteArray#,+     utf8DecodeForeignPtr,+     -- *  Counting characters+     utf8CountCharsByteArray#,+     -- *  Comparison+     utf8CompareByteArray#,+     -- *  Encoding strings+     utf8EncodePtr,+     utf8EncodeByteArray#,+     utf8EncodedLength+     ) where++import GHC.Internal.Encoding.UTF8
+ src/GHC/Enum.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Enum+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- The 'Enum' and 'Bounded' classes.+--++module GHC.Enum(+        Bounded(..), Enum(..),+        boundedEnumFrom, boundedEnumFromThen,+        toEnumError, fromEnumError, succError, predError,+   ) where++import GHC.Internal.Enum
+ src/GHC/Environment.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE Safe #-}++module GHC.Environment+    (getFullArgs+     ) where++import GHC.Internal.Environment
+ src/GHC/Err.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Err+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- The "GHC.Err" module defines the code for the wired-in error functions,+-- which have a special type in the compiler (with \"open tyvars\").+--+-- We cannot define these functions in a module where they might be used+-- (e.g., "GHC.Base"), because the magical wired-in type will get confused+-- with what the typechecker figures out.+--++module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where++import GHC.Internal.Err
+ src/GHC/Event.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}++-- |+-- This module provides scalable event notification for file+-- descriptors and timeouts.+--+-- This module should be considered GHC internal.+--+-- ----------------------------------------------------------------------------++#if defined(javascript_HOST_ARCH)++module GHC.Event ( ) where++#else++module GHC.Event+    (-- *  Types+     EventManager,+     TimerManager,+     -- *  Creation+     getSystemEventManager,+     new,+     getSystemTimerManager,+     -- *  Registering interest in I/O events+     Event,+     evtRead,+     evtWrite,+     IOCallback,+     FdKey(keyFd),+     Lifetime(..),+     registerFd,+     unregisterFd,+     unregisterFd_,+     closeFd,+     -- *  Registering interest in timeout events+     TimeoutCallback,+     TimeoutKey,+     registerTimeout,+     updateTimeout,+     unregisterTimeout+     ) where++import GHC.Internal.Event++#endif
+ src/GHC/Event/TimeOut.hs view
@@ -0,0 +1,24 @@+-- |+-- Module      :  GHC.Event.TimeOut+-- Copyright   :  (c) Tamar Christina 2018+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- Common Timer definitions shared between WinIO and RIO.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.++module GHC.Event.TimeOut+    ( TimeoutQueue+    , TimeoutCallback+    , TimeoutEdit+    , TimeoutKey(..)+    ) where++import GHC.Internal.Event.TimeOut
+ src/GHC/Event/Windows.hs view
@@ -0,0 +1,61 @@+-- |+-- Module      :  GHC.Event.Windows+-- Copyright   :  (c) Tamar Christina 2018+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- WinIO Windows event manager.+--++module GHC.Event.Windows (+    -- * Manager+    Manager,+    getSystemManager,+    interruptSystemManager,+    wakeupIOManager,+    processRemoteCompletion,++    -- * Overlapped I/O+    associateHandle,+    associateHandle',+    withOverlapped,+    withOverlappedEx,+    StartCallback,+    StartIOCallback,+    CbResult(..),+    CompletionCallback,+    LPOVERLAPPED,++    -- * Timeouts+    TimeoutCallback,+    TimeoutKey,+    Seconds,+    registerTimeout,+    updateTimeout,+    unregisterTimeout,++    -- * Utilities+    withException,+    ioSuccess,+    ioFailed,+    ioFailedAny,+    getLastError,++    -- * I/O Result type+    IOResult(..),++    -- * I/O Event notifications+    HandleData (..), -- seal for release+    HandleKey (handleValue),+    registerHandle,+    unregisterHandle,++    -- * Console events+    module GHC.Internal.Event.Windows.ConsoleEvent+) where++import GHC.Internal.Event.Windows+import GHC.Internal.Event.Windows.ConsoleEvent
+ src/GHC/Event/Windows/Clock.hs view
@@ -0,0 +1,12 @@+module GHC.Event.Windows.Clock (+    Clock,+    Seconds,+    getTime,+    getClock,++    -- * Specific implementations+    queryPerformanceCounter,+    getTickCount64+) where++import GHC.Internal.Event.Windows.Clock
+ src/GHC/Event/Windows/ConsoleEvent.hs view
@@ -0,0 +1,21 @@+-- |+-- Module      :  GHC.Event.Windows.ConsoleEvent+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Windows I/O manager interfaces. Depending on which I/O Subsystem is used+-- requests will be routed to different places.+--++module GHC.Event.Windows.ConsoleEvent (+  ConsoleEvent (..),+  start_console_handler,+  toWin32ConsoleEvent,+  win32ConsoleHandler+) where++import GHC.Internal.Event.Windows.ConsoleEvent
+ src/GHC/Event/Windows/FFI.hs view
@@ -0,0 +1,59 @@+-- |+-- Module      :  GHC.Event.Windows.FFI+-- Copyright   :  (c) Tamar Christina 2019+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- WinIO Windows API Foreign Function imports+--++module GHC.Event.Windows.FFI (+    -- * IOCP+    IOCP(..),+    CompletionKey,+    newIOCP,+    associateHandleWithIOCP,+    getQueuedCompletionStatusEx,+    postQueuedCompletionStatus,+    getOverlappedResult,++    -- * Completion Data+    CompletionData(..),+    CompletionCallback,+    withRequest,++    -- * Overlapped+    OVERLAPPED,+    LPOVERLAPPED,+    OVERLAPPED_ENTRY(..),+    LPOVERLAPPED_ENTRY,+    HASKELL_OVERLAPPED,+    LPHASKELL_OVERLAPPED,+    allocOverlapped,+    zeroOverlapped,+    pokeOffsetOverlapped,+    overlappedIOStatus,+    overlappedIONumBytes,++    -- * Cancel pending I/O+    cancelIoEx,+    cancelIoEx',++    -- * Monotonic time++    -- ** GetTickCount+    getTickCount64,++    -- ** QueryPerformanceCounter+    queryPerformanceCounter,+    queryPerformanceFrequency,++    -- ** Miscellaneous+    throwWinErr,+    setLastError+  ) where++import GHC.Internal.Event.Windows.FFI
+ src/GHC/Event/Windows/ManagedThreadPool.hs view
@@ -0,0 +1,23 @@+-- |+-- Module      :  GHC.Event.Windows.ManagedThreadPool+-- Copyright   :  (c) Tamar Christina 2019+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- WinIO Windows Managed Thread pool API.  This thread pool scales dynamically+-- based on demand.+--+-------------------------------------------------------------------------------++module GHC.Event.Windows.ManagedThreadPool+  ( ThreadPool(..)+  , startThreadPool+  , notifyRunning+  , notifyWaiting+  , monitorThreadPool+  ) where++import GHC.Internal.Event.Windows.ManagedThreadPool
+ src/GHC/Event/Windows/Thread.hs view
@@ -0,0 +1,8 @@+module GHC.Event.Windows.Thread (+    ensureIOManagerIsRunning,+    interruptIOManager,+    threadDelay,+    registerDelay,+) where++import GHC.Internal.Event.Windows.Thread
+ src/GHC/Exception.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Exception+-- Copyright   :  (c) The University of Glasgow, 1998-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Exceptions and exception-handling functions.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.Exception+    ( -- * 'Exception' class+      Exception(..)++      -- * 'SomeException'+    , SomeException(..)++      -- * Throwing+    , throw++      -- * Concrete exceptions+      -- ** Arithmetic exceptions+    , ArithException(..)+    , divZeroException+    , overflowException+    , ratioZeroDenomException+    , underflowException+      -- ** 'ErrorCall'+    , ErrorCall(..)+    , errorCallException+    , errorCallWithCallStackException++      -- * Reexports+      -- Re-export CallStack and SrcLoc from GHC.Types+    , CallStack, fromCallSiteList, getCallStack, prettyCallStack+    , prettyCallStackLines+    , SrcLoc(..), prettySrcLoc+    ) where++import GHC.Internal.Exception++-- XXX: This is a temporary workaround to ensure correct build ordering+-- despite #24436 since `GHC.Internal.Stack` has a .hs-boot file which+-- `ghc -M` does not track correctly.+-- This dependency should be removed when #24436 is fixed.+import GHC.Internal.Stack ()
+ src/GHC/Exception/Type.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Exception.Type+-- Copyright   :  (c) The University of Glasgow, 1998-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  cvs-ghc@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Exceptions and exception-handling functions.+--++module GHC.Exception.Type+       ( Exception(..)    -- Class+       , SomeException(..), ArithException(..)+       , divZeroException, overflowException, ratioZeroDenomException+       , underflowException+       ) where++import GHC.Internal.Exception.Type
+ src/GHC/ExecutionStack.hs view
@@ -0,0 +1,38 @@+-- |+--+-- Module      :  GHC.ExecutionStack+-- Copyright   :  (c) The University of Glasgow 2013-2015+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@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 GHC.Internal.ExecutionStack
+ src/GHC/Exts.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE MagicHash #-}++-- |+--+-- Module      :  GHC.Exts+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- GHC Extensions: this is the Approved Way to get at GHC-specific extensions.+--+-- Note: no other @base@ module should import this module.++-- See Note [Where do we export PrimOps] for details about how to expose primops+-- to users.++module GHC.Exts+    (-- **  Pointer types+     Ptr(..),+     FunPtr(..),+     -- **  Other primitive types+     module GHC.Types,+     -- **  Legacy interface for arrays of arrays+     module GHC.Internal.ArrayArray,+     -- *  Primitive operations+     module GHC.Prim,+     module GHC.Prim.Ext,+     -- **  Running 'RealWorld' state thread+     runRW#,+     -- **  Bit shift operations+     shiftL#,+     shiftRL#,+     iShiftL#,+     iShiftRA#,+     iShiftRL#,+     -- **  Pointer comparison operations+     reallyUnsafePtrEquality,+     unsafePtrEquality#,+     eqStableName#,+     sameArray#,+     sameMutableArray#,+     sameSmallArray#,+     sameSmallMutableArray#,+     sameByteArray#,+     sameMutableByteArray#,+     sameMVar#,+     sameMutVar#,+     sameTVar#,+     samePromptTag#,+     -- **  Compat wrapper+     atomicModifyMutVar#,+     -- **  Resize functions+     -- |  Resizing arrays of boxed elements is currently handled in+     -- library space (rather than being a primop) since there is not+     -- an efficient way to grow arrays. However, resize operations+     -- may become primops in a future release of GHC.+     resizeSmallMutableArray#,+     -- **  Fusion+     build,+     augment,+     -- *  Overloaded lists+     IsList(..),+     -- *  Transform comprehensions+     Down(..),+     groupWith,+     sortWith,+     the,+     -- *  Strings+     -- **  Overloaded string literals+     IsString(..),+     -- **  CString+     unpackCString#,+     unpackAppendCString#,+     unpackFoldrCString#,+     unpackCStringUtf8#,+     unpackNBytes#,+     cstringLength#,+     -- *  Debugging+     -- **  Breakpoints+     breakpoint,+     breakpointCond,+     -- **  Event logging+     traceEvent,+     -- **  The call stack+     currentCallStack,+     -- *  Ids with special behaviour+     inline,+     noinline,+     lazy,+     oneShot,+     considerAccessible,+     seq#,+     -- *  SpecConstr annotations+     SpecConstrAnnotation(..),+     SPEC(..),+     -- *  Coercions+     -- **  Safe coercions+     -- |  These are available from the /Trustworthy/ module "Data.Coerce" as well.+     --+     -- @since 4.7.0.0+     coerce,+     -- **  Very unsafe coercion+     unsafeCoerce#,+     -- **  Casting class dictionaries with single methods+     WithDict(..),+     -- *  Converting ADTs to constructor tags+     DataToTag(..),+     -- *  The maximum tuple size+     maxTupleSize+     ) where++import GHC.Internal.Exts+import GHC.Internal.ArrayArray+import GHC.Prim hiding+  ( coerce+  -- Hide dataToTag# ops because they are expected to break for+  -- GHC-internal reasons in the near future, and shouldn't+  -- be exposed from base (not even GHC.Exts)+  , dataToTagSmall#, dataToTagLarge#+  -- whereFrom# is similarly internal.+  , whereFrom#+  , isByteArrayWeaklyPinned#, isMutableByteArrayWeaklyPinned#++  -- Don't re-export vector FMA instructions+  , fmaddFloatX4#+  , fmsubFloatX4#+  , fnmaddFloatX4#+  , fnmsubFloatX4#+  , fmaddFloatX8#+  , fmsubFloatX8#+  , fnmaddFloatX8#+  , fnmsubFloatX8#+  , fmaddFloatX16#+  , fmsubFloatX16#+  , fnmaddFloatX16#+  , fnmsubFloatX16#+  , fmaddDoubleX2#+  , fmsubDoubleX2#+  , fnmaddDoubleX2#+  , fnmsubDoubleX2#+  , fmaddDoubleX4#+  , fmsubDoubleX4#+  , fnmaddDoubleX4#+  , fnmsubDoubleX4#+  , fmaddDoubleX8#+  , fmsubDoubleX8#+  , fnmaddDoubleX8#+  , fnmsubDoubleX8#+  -- Don't re-export SIMD shuffle primops+  , shuffleDoubleX2#+  , shuffleDoubleX4#+  , shuffleDoubleX8#+  , shuffleFloatX16#+  , shuffleFloatX4#+  , shuffleFloatX8#+  , shuffleInt16X16#+  , shuffleInt16X32#+  , shuffleInt16X8#+  , shuffleInt32X16#+  , shuffleInt32X4#+  , shuffleInt32X8#+  , shuffleInt64X2#+  , shuffleInt64X4#+  , shuffleInt64X8#+  , shuffleInt8X16#+  , shuffleInt8X32#+  , shuffleInt8X64#+  , shuffleWord16X16#+  , shuffleWord16X32#+  , shuffleWord16X8#+  , shuffleWord32X16#+  , shuffleWord32X4#+  , shuffleWord32X8#+  , shuffleWord64X2#+  , shuffleWord64X4#+  , shuffleWord64X8#+  , shuffleWord8X16#+  , shuffleWord8X32#+  , shuffleWord8X64#+  -- Don't re-export min/max primops+  , maxDouble#+  , maxDoubleX2#+  , maxDoubleX4#+  , maxDoubleX8#+  , maxFloat#+  , maxFloatX16#+  , maxFloatX4#+  , maxFloatX8#+  , maxInt16X16#+  , maxInt16X32#+  , maxInt16X8#+  , maxInt32X16#+  , maxInt32X4#+  , maxInt32X8#+  , maxInt64X2#+  , maxInt64X4#+  , maxInt64X8#+  , maxInt8X16#+  , maxInt8X32#+  , maxInt8X64#+  , maxWord16X16#+  , maxWord16X32#+  , maxWord16X8#+  , maxWord32X16#+  , maxWord32X4#+  , maxWord32X8#+  , maxWord64X2#+  , maxWord64X4#+  , maxWord64X8#+  , maxWord8X16#+  , maxWord8X32#+  , maxWord8X64#+  , minDouble#+  , minDoubleX2#+  , minDoubleX4#+  , minDoubleX8#+  , minFloat#+  , minFloatX16#+  , minFloatX4#+  , minFloatX8#+  , minInt16X16#+  , minInt16X32#+  , minInt16X8#+  , minInt32X16#+  , minInt32X4#+  , minInt32X8#+  , minInt64X2#+  , minInt64X4#+  , minInt64X8#+  , minInt8X16#+  , minInt8X32#+  , minInt8X64#+  , minWord16X16#+  , minWord16X32#+  , minWord16X8#+  , minWord32X16#+  , minWord32X4#+  , minWord32X8#+  , minWord64X2#+  , minWord64X4#+  , minWord64X8#+  , minWord8X16#+  , minWord8X32#+  , minWord8X64#+  )++import GHC.Prim.Ext++import GHC.Types hiding (+  IO,   -- Exported from "GHC.IO"+  Type, -- Exported from "Data.Kind"+  -- GHC's internal representation of 'TyCon's, for 'Typeable'+  Module, TrName, TyCon, TypeLitSort, KindRep, KindBndr,+  Unit#,+  Solo#(..),+  Tuple0#,+  Tuple1#,+  Tuple2#,+  Tuple3#,+  Tuple4#,+  Tuple5#,+  Tuple6#,+  Tuple7#,+  Tuple8#,+  Tuple9#,+  Tuple10#,+  Tuple11#,+  Tuple12#,+  Tuple13#,+  Tuple14#,+  Tuple15#,+  Tuple16#,+  Tuple17#,+  Tuple18#,+  Tuple19#,+  Tuple20#,+  Tuple21#,+  Tuple22#,+  Tuple23#,+  Tuple24#,+  Tuple25#,+  Tuple26#,+  Tuple27#,+  Tuple28#,+  Tuple29#,+  Tuple30#,+  Tuple31#,+  Tuple32#,+  Tuple33#,+  Tuple34#,+  Tuple35#,+  Tuple36#,+  Tuple37#,+  Tuple38#,+  Tuple39#,+  Tuple40#,+  Tuple41#,+  Tuple42#,+  Tuple43#,+  Tuple44#,+  Tuple45#,+  Tuple46#,+  Tuple47#,+  Tuple48#,+  Tuple49#,+  Tuple50#,+  Tuple51#,+  Tuple52#,+  Tuple53#,+  Tuple54#,+  Tuple55#,+  Tuple56#,+  Tuple57#,+  Tuple58#,+  Tuple59#,+  Tuple60#,+  Tuple61#,+  Tuple62#,+  Tuple63#,+  Tuple64#,+  Sum2#,+  Sum3#,+  Sum4#,+  Sum5#,+  Sum6#,+  Sum7#,+  Sum8#,+  Sum9#,+  Sum10#,+  Sum11#,+  Sum12#,+  Sum13#,+  Sum14#,+  Sum15#,+  Sum16#,+  Sum17#,+  Sum18#,+  Sum19#,+  Sum20#,+  Sum21#,+  Sum22#,+  Sum23#,+  Sum24#,+  Sum25#,+  Sum26#,+  Sum27#,+  Sum28#,+  Sum29#,+  Sum30#,+  Sum31#,+  Sum32#,+  Sum33#,+  Sum34#,+  Sum35#,+  Sum36#,+  Sum37#,+  Sum38#,+  Sum39#,+  Sum40#,+  Sum41#,+  Sum42#,+  Sum43#,+  Sum44#,+  Sum45#,+  Sum46#,+  Sum47#,+  Sum48#,+  Sum49#,+  Sum50#,+  Sum51#,+  Sum52#,+  Sum53#,+  Sum54#,+  Sum55#,+  Sum56#,+  Sum57#,+  Sum58#,+  Sum59#,+  Sum60#,+  Sum61#,+  Sum62#,+  Sum63#,+  )
+ src/GHC/Fingerprint.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Safe #-}++module GHC.Fingerprint (+        Fingerprint(..), fingerprint0,+        fingerprintData,+        fingerprintString,+        fingerprintFingerprints,+        getFileHash+   ) where++import GHC.Internal.Fingerprint
+ src/GHC/Fingerprint/Type.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.Fingerprint.Type+-- Copyright   :  (c) The University of Glasgow, 1994-2023+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Fingerprints for recompilation checking and ABI versioning, and+-- implementing fast comparison of Typeable.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.++module GHC.Fingerprint.Type+    (Fingerprint(..)+     ) where++import GHC.Internal.Fingerprint.Type
+ src/GHC/Float.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Float+-- Copyright   :  (c) The University of Glasgow 1994-2002+--                Portions obtained from hbc (c) Lennart Augusstson+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The types 'Float' and 'Double', the classes 'Floating' and 'RealFloat' and+-- casting between Word32 and Float and Word64 and Double.+--++module GHC.Float+    (-- *  Classes+     Floating(..),+     RealFloat(..),+     -- *  'Float'+     Float(..),+     Float#,+     -- **  Conversion+     float2Int,+     int2Float,+     word2Float,+     integerToFloat#,+     naturalToFloat#,+     rationalToFloat,+     castWord32ToFloat,+     castFloatToWord32,+     castWord32ToFloat#,+     castFloatToWord32#,+     float2Double,+     -- **  Operations+     floorFloat,+     ceilingFloat,+     truncateFloat,+     roundFloat,+     properFractionFloat,+     -- **  Predicate+     isFloatDenormalized,+     isFloatFinite,+     isFloatInfinite,+     isFloatNaN,+     isFloatNegativeZero,+     -- **  Comparison+     gtFloat,+     geFloat,+     leFloat,+     ltFloat,+     -- **  Arithmetic+     plusFloat,+     minusFloat,+     timesFloat,+     divideFloat,+     negateFloat,+     expFloat,+     expm1Float,+     logFloat,+     log1pFloat,+     sqrtFloat,+     fabsFloat,+     sinFloat,+     cosFloat,+     tanFloat,+     asinFloat,+     acosFloat,+     atanFloat,+     sinhFloat,+     coshFloat,+     tanhFloat,+     asinhFloat,+     acoshFloat,+     atanhFloat,+     -- *  'Double'+     Double(..),+     Double#,+     -- **  Conversion+     double2Int,+     int2Double,+     word2Double,+     integerToDouble#,+     naturalToDouble#,+     rationalToDouble,+     castWord64ToDouble,+     castDoubleToWord64,+     castWord64ToDouble#,+     castDoubleToWord64#,+     double2Float,+     -- **  Operations+     floorDouble,+     ceilingDouble,+     truncateDouble,+     roundDouble,+     properFractionDouble,+     -- **  Predicate+     isDoubleDenormalized,+     isDoubleFinite,+     isDoubleInfinite,+     isDoubleNaN,+     isDoubleNegativeZero,+     -- **  Comparison+     gtDouble,+     geDouble,+     leDouble,+     ltDouble,+     -- **  Arithmetic+     plusDouble,+     minusDouble,+     timesDouble,+     divideDouble,+     negateDouble,+     expDouble,+     expm1Double,+     logDouble,+     log1pDouble,+     sqrtDouble,+     fabsDouble,+     sinDouble,+     cosDouble,+     tanDouble,+     asinDouble,+     acosDouble,+     atanDouble,+     sinhDouble,+     coshDouble,+     tanhDouble,+     asinhDouble,+     acoshDouble,+     atanhDouble,+     -- *  Formatting+     showFloat,+     FFFormat(..),+     formatRealFloat,+     formatRealFloatAlt,+     showSignedFloat,+     -- *  Operations+     log1mexpOrd,+     roundTo,+     floatToDigits,+     integerToBinaryFloat',+     fromRat,+     fromRat',+     roundingMode#,+     -- *  Monomorphic equality operators+     -- |  See GHC.Classes#matching_overloaded_methods_in_rules+     eqFloat,+     eqDouble,+     -- *  Internal+     -- |  These may vanish in a future release+     clamp,+     expt,+     expts,+     expts10,+     fromRat'',+     maxExpt,+     maxExpt10,+     minExpt,+     powerDouble,+     powerFloat,+     stgDoubleToWord64,+     stgFloatToWord32,+     stgWord64ToDouble,+     stgWord32ToFloat+     ) where++import GHC.Internal.Float
+ src/GHC/Float/ConversionUtils.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Float.ConversionUtils+-- Copyright   :  (c) Daniel Fischer 2010+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Utilities for conversion between Double/Float and Rational+--++module GHC.Float.ConversionUtils+    (elimZerosInteger,+     elimZerosInt#+     ) where++import GHC.Internal.Float.ConversionUtils
+ src/GHC/Float/RealFracMethods.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Float.RealFracMethods+-- Copyright   :  (c) Daniel Fischer 2010+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Methods for the RealFrac instances for 'Float' and 'Double',+-- with specialised versions for 'Int'.+--+-- Moved to their own module to not bloat "GHC.Float" further.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.Float.RealFracMethods+    (-- *  Double methods+     -- **  Integer results+     properFractionDoubleInteger,+     truncateDoubleInteger,+     floorDoubleInteger,+     ceilingDoubleInteger,+     roundDoubleInteger,+     -- **  Int results+     properFractionDoubleInt,+     floorDoubleInt,+     ceilingDoubleInt,+     roundDoubleInt,+     -- *  Double/Int conversions, wrapped primops+     double2Int,+     int2Double,+     -- *  Float methods+     -- **  Integer results+     properFractionFloatInteger,+     truncateFloatInteger,+     floorFloatInteger,+     ceilingFloatInteger,+     roundFloatInteger,+     -- **  Int results+     properFractionFloatInt,+     floorFloatInt,+     ceilingFloatInt,+     roundFloatInt,+     -- *  Float/Int conversions, wrapped primops+     float2Int,+     int2Float+     ) where++import GHC.Internal.Float.RealFracMethods
+ src/GHC/Foreign.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.Foreign+-- Copyright   :  (c) The University of Glasgow, 2008-2011+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Foreign marshalling support for CStrings with configurable encodings+--++module GHC.Foreign+    (-- *  C strings with a configurable encoding+     CString,+     CStringLen,+     -- *  Conversion of C strings into Haskell strings+     peekCString,+     peekCStringLen,+     -- *  Conversion of Haskell strings into C strings+     newCString,+     newCStringLen,+     newCStringLen0,+     -- *  Conversion of Haskell strings into C strings using temporary storage+     withCString,+     withCStringLen,+     withCStringLen0,+     withCStringsLen,+     charIsRepresentable+     ) where++import GHC.Internal.Foreign.C.String.Encoding
+ src/GHC/ForeignPtr.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.ForeignPtr+-- Copyright   :  (c) The University of Glasgow, 1992-2003+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC's implementation of the 'ForeignPtr' data type.+--++module GHC.ForeignPtr+  (+        -- * Types+        ForeignPtr(..),+        ForeignPtrContents(..),+        Finalizers(..),+        FinalizerPtr,+        FinalizerEnvPtr,+        -- * Create+        newForeignPtr_,+        mallocForeignPtr,+        mallocPlainForeignPtr,+        mallocForeignPtrBytes,+        mallocPlainForeignPtrBytes,+        mallocForeignPtrAlignedBytes,+        mallocPlainForeignPtrAlignedBytes,+        newConcForeignPtr,+        -- * Add Finalizers+        addForeignPtrFinalizer,+        addForeignPtrFinalizerEnv,+        addForeignPtrConcFinalizer,+        -- * Conversion+        unsafeForeignPtrToPtr,+        castForeignPtr,+        plusForeignPtr,+        -- * Control over lifetype+        withForeignPtr,+        unsafeWithForeignPtr,+        touchForeignPtr,+        -- * Finalization+        finalizeForeignPtr+        -- * Commentary+        -- $commentary+  ) where++import GHC.Internal.ForeignPtr++{- $commentary++This is a high-level overview of how 'ForeignPtr' works.+The implementation of 'ForeignPtr' must accomplish several goals:++1. Invoke a finalizer once a foreign pointer becomes unreachable.+2. Support augmentation of finalizers, i.e. 'addForeignPtrFinalizer'.+   As a motivating example, suppose that the payload of a foreign+   pointer is C struct @bar@ that has an optionally NULL pointer field+   @foo@ to an unmanaged heap object. Initially, @foo@ is NULL, and+   later the program uses @malloc@, initializes the object, and assigns+   @foo@ the address returned by @malloc@. When the foreign pointer+   becomes unreachable, it is now necessary to first @free@ the object+   pointed to by @foo@ and then invoke whatever finalizer was associated+   with @bar@. That is, finalizers must be invoked in the opposite order+   they are added.+3. Allow users to invoke a finalizer promptly if they know that the+   foreign pointer is unreachable, i.e. 'finalizeForeignPtr'.++How can these goals be accomplished? Goal 1 suggests that weak references+and finalizers (via 'Weak#' and 'mkWeak#') are necessary. But how should+they be used and what should their key be?  Certainly not 'ForeignPtr' or+'ForeignPtrContents'. See the warning in "GHC.Weak" about weak pointers with+lifted (non-primitive) keys. The two finalizer-supporting data constructors of+'ForeignPtr' have an @'IORef' 'Finalizers'@ (backed by 'MutVar#') field.+This gets used in two different ways depending on the kind of finalizer:++* 'HaskellFinalizers': The first @addForeignPtrConcFinalizer_@ call uses+  'mkWeak#' to attach the finalizer @foreignPtrFinalizer@ to the 'MutVar#'.+  The resulting 'Weak#' is discarded (see @addForeignPtrConcFinalizer_@).+  Subsequent calls to @addForeignPtrConcFinalizer_@ (goal 2) just add+  finalizers onto the list in the 'HaskellFinalizers' data constructor.+* 'CFinalizers': The first 'addForeignPtrFinalizer' call uses+  'mkWeakNoFinalizer#' to create a 'Weak#'. The 'Weak#' is preserved in the+  'CFinalizers' data constructor. Both the first call and subsequent+  calls (goal 2) use 'addCFinalizerToWeak#' to attach finalizers to the+  'Weak#' itself. Also, see Note [MallocPtr finalizers] for discussion of+  the key and value of this 'Weak#'.++In either case, the runtime invokes the appropriate finalizers when the+'ForeignPtr' becomes unreachable.+-}
+ src/GHC/GHCi.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.GHCi+-- Copyright   :  (c) The University of Glasgow 2012+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The GHCi Monad lifting interface.+--+-- EXPERIMENTAL! DON'T USE.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.GHCi+    {-# WARNING "This is an unstable interface." #-}+    (GHCiSandboxIO(..),+     NoIO()+     ) where++import GHC.Internal.GHCi
+ src/GHC/GHCi/Helpers.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.GHCi.Helpers+-- Copyright   :  (c) The GHC Developers+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Various helpers used by the GHCi shell.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.GHCi.Helpers+    (disableBuffering,+     flushAll,+     evalWrapper+     ) where++import GHC.Internal.GHCi.Helpers
+ src/GHC/Generics.hs view
@@ -0,0 +1,694 @@+{-# LANGUAGE Safe #-}++{-# LANGUAGE ExplicitNamespaces #-}++-- |+-- Module      :  GHC.Generics+-- Copyright   :  (c) Universiteit Utrecht 2010-2011, University of Oxford 2012-2014+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- @since 4.6.0.0+--+-- If you're using @GHC.Generics@, you should consider using the+-- <http://hackage.haskell.org/package/generic-deriving> package, which+-- contains many useful generic functions.++module GHC.Generics  (+-- * Introduction+--+-- |+--+-- 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+-- datatype-generic function is then an overloaded function with instances+-- for most of these type constructors, together with a wrapper that performs+-- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need+-- a few generic instances in order to implement functionality that works for any+-- representable type.+--+-- Representable types are collected in the 'Generic' class, which defines the+-- associated type 'Rep' as well as conversion functions 'from' and 'to'.+-- Typically, you will not define 'Generic' instances by hand, but have the compiler+-- derive them for you.++-- ** Representing datatypes+--+-- |+--+-- The key to defining your own datatype-generic functions is to understand how to+-- represent datatypes using the given set of type constructors.+--+-- Let us look at an example first:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+--   deriving 'Generic'+-- @+--+-- The above declaration (which requires the language pragma @DeriveGeneric@)+-- causes the following representation to be generated:+--+-- @+-- instance 'Generic' (Tree a) where+--   type 'Rep' (Tree a) =+--     'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)+--       ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)+--          ('S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--                 ('Rec0' a))+--        ':+:'+--        'C1' ('MetaCons \"Node\" 'PrefixI 'False)+--          ('S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--                ('Rec0' (Tree a))+--           ':*:'+--           'S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--                ('Rec0' (Tree a))))+--   ...+-- @+--+-- /Hint:/ You can obtain information about the code being generated from GHC by passing+-- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using+-- the @:kind!@ command.+--+-- 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.+--+-- Here is a reduced representation for @Tree@ with nearly all meta-information removed,+-- for now keeping only the most essential aspects:+--+-- @+-- instance 'Generic' (Tree a) where+--   type 'Rep' (Tree a) =+--     'Rec0' a+--     ':+:'+--     ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a))+-- @+--+-- The @Tree@ datatype has two constructors. The representation of individual constructors+-- is combined using the binary type constructor ':+:'.+--+-- The first constructor consists of a single field, which is the parameter @a@. This is+-- 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+-- the binary type constructor ':*:'.+--+-- Now let us explain the additional tags being used in the complete representation:+--+--    * 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:+--+--      * 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, 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' ('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+--+-- |+--+-- There are many datatype-generic functions that do not distinguish between positions that+-- are parameters or positions that are recursive calls. There are also many datatype-generic+-- functions that do not care about the names of datatypes and constructors at all. To keep+-- the number of cases to consider in generic functions in such a situation to a minimum,+-- it turns out that many of the type constructors introduced above are actually synonyms,+-- defining them to be variants of a smaller set of constructors.++-- *** Individual fields of constructors: 'K1'+--+-- |+--+-- The type constructor 'Rec0' is a variant of 'K1':+--+-- @+-- type 'Rec0' = 'K1' 'R'+-- @+--+-- 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'+--+-- |+--+-- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1':+--+-- @+-- type 'S1' = 'M1' 'S'+-- type 'C1' = 'M1' 'C'+-- type 'D1' = 'M1' 'D'+-- @+--+-- The types 'S', 'C' and 'D' are once again type-level proxies, just used to create+-- several variants of 'M1'.++-- *** Additional generic representation type constructors+--+-- |+--+-- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur+-- in the representations of other datatypes.++-- **** Empty datatypes: 'V1'+--+-- |+--+-- For empty datatypes, 'V1' is used as a representation. For example,+--+-- @+-- data Empty deriving 'Generic'+-- @+--+-- yields+--+-- @+-- instance 'Generic' Empty where+--   type 'Rep' Empty =+--     'D1' ('MetaData \"Empty\" \"Main\" \"package-name\" 'False) 'V1'+-- @++-- **** Constructors without fields: 'U1'+--+-- |+--+-- If a constructor has no arguments, then 'U1' is used as its representation. For example+-- the representation of 'Bool' is+--+-- @+-- instance 'Generic' Bool where+--   type 'Rep' Bool =+--     '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+--+-- |+--+-- As ':+:' and ':*:' are just binary operators, one might ask what happens if the+-- datatype has more than two constructors, or a constructor with more than two+-- fields. The answer is simple: the operators are used several times, to combine+-- all the constructors and fields as needed. However, users /should not rely on+-- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is+-- free to choose any nesting it prefers. (In practice, the current implementation+-- tries to produce a more-or-less balanced nesting, so that the traversal of+-- the structure of the datatype from the root to a particular component can be+-- performed in logarithmic rather than linear time.)++-- ** Defining datatype-generic functions+--+-- |+--+-- A datatype-generic function comprises two parts:+--+--    1. /Generic instances/ for the function, implementing it for most of the representation+--       type constructors introduced above.+--+--    2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion+--       between the original value and its `Rep`-based representation and then invokes the+--       generic instances.+--+-- As an example, let us look at a function @encode@ that produces a naive, but lossless+-- bit encoding of values of various datatypes. So we are aiming to define a function+--+-- @+-- encode :: 'Generic' a => a -> [Bool]+-- @+--+-- where we use 'Bool' as our datatype for bits.+--+-- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized+-- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation+-- type constructors operate with kind @* -> *@ as base kind. But the type argument is never+-- being used. This may be changed at some point in the future. The class has a single method,+-- and we use the type we want our final function to have, but we replace the occurrences of+-- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used).+--+-- > class Encode' f where+-- >   encode' :: f p -> [Bool]+--+-- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define+-- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'.++-- *** Definition of the generic representation types+--+-- |+--+-- In order to be able to do this, we need to know the actual definitions of these types:+--+-- @+-- data    'V1'        p                       -- lifted version of Empty+-- data    'U1'        p = 'U1'                  -- lifted version of ()+-- data    (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either'+-- data    (':*:') f g p = (f p) ':*:' (g p)     -- lifted version of (,)+-- newtype 'K1'    i c p = 'K1' { 'unK1' :: c }    -- a container for a c+-- newtype 'M1'  i t f p = 'M1' { 'unM1' :: f p }  -- a wrapper+-- @+--+-- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either',+-- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value+-- of a specific type @c@, and 'M1' wraps a value of the generic type argument,+-- which in the lifted world is an @f p@ (where we do not care about @p@).++-- *** Generic instances+--+-- |+--+-- To deal with the 'V1' case, we use the following code (which requires the pragma @EmptyCase@):+--+-- @+-- instance Encode' 'V1' where+--   encode' x = case x of { }+-- @+--+-- There are no values of type @V1 p@ to pass, so it is impossible for this+-- function to be invoked. One can ask why it is useful to define an instance+-- for 'V1' at all in this case? Well, an empty type can be used as an argument+-- to a non-empty type, and you might still want to encode the resulting type.+-- As a somewhat contrived example, consider @[Empty]@, which is not an empty+-- type, but contains just the empty list. The 'V1' instance ensures that we+-- can call the generic function on such types.+--+-- There is exactly one value of type 'U1', so encoding it requires no+-- knowledge, and we can use zero bits:+--+-- @+-- instance Encode' 'U1' where+--   encode' 'U1' = []+-- @+--+-- In the case for ':+:', we produce 'False' or 'True' depending on whether+-- the constructor of the value provided is located on the left or on the right:+--+-- @+-- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where+--   encode' ('L1' x) = False : encode' x+--   encode' ('R1' x) = True  : encode' x+-- @+--+-- (Note that this encoding strategy may not be reliable across different+-- versions of GHC. Recall that the compiler is free to choose any nesting+-- of ':+:' it chooses, so if GHC chooses @(a ':+:' b) ':+:' c@, then the+-- encoding for @a@ would be @[False, False]@, @b@ would be @[False, True]@,+-- and @c@ would be @[True]@. However, if GHC chooses @a ':+:' (b ':+:' c)@,+-- then the encoding for @a@ would be @[False]@, @b@ would be @[True, False]@,+-- and @c@ would be @[True, True]@.)+--+-- In the case for ':*:', we append the encodings of the two subcomponents:+--+-- @+-- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where+--   encode' (x ':*:' y) = encode' x ++ encode' y+-- @+--+-- The case for 'K1' is rather interesting. Here, we call the final function+-- @encode@ that we yet have to define, recursively. We will use another type+-- class @Encode@ for that function:+--+-- @+-- instance (Encode c) => Encode' ('K1' i c) where+--   encode' ('K1' x) = encode x+-- @+--+-- Note how we can define a uniform instance for 'M1', because we completely+-- disregard all meta-information:+--+-- @+-- instance (Encode' f) => Encode' ('M1' i t f) where+--   encode' ('M1' x) = encode' x+-- @+--+-- Unlike in 'K1', the instance for 'M1' refers to @encode'@, not @encode@.++-- *** The wrapper and generic default+--+-- |+--+-- We now define class @Encode@ for the actual @encode@ function:+--+-- @+-- class Encode a where+--   encode :: a -> [Bool]+--   default encode :: (Generic a, Encode' (Rep a)) => a -> [Bool]+--   encode x = encode' ('from' x)+-- @+--+-- The incoming @x@ is converted using 'from', then we dispatch to the+-- generic instances using @encode'@. We use this as a default definition+-- for @encode@. We need the @default encode@ signature because ordinary+-- Haskell default methods must not introduce additional class constraints,+-- but our generic default does.+--+-- Defining a particular instance is now as simple as saying+--+-- @+-- instance (Encode a) => Encode (Tree a)+-- @+--+-- The generic default is being used. In the future, it will hopefully be+-- possible to use @deriving Encode@ as well, but GHC does not yet support+-- that syntax for this situation.+--+-- Having @Encode@ as a class has the advantage that we can define+-- non-generic special cases, which is particularly useful for abstract+-- datatypes that have no structural representation. For example, given+-- a suitable integer encoding function @encodeInt@, we can define+--+-- @+-- instance Encode Int where+--   encode = encodeInt+-- @++-- *** Omitting generic instances+--+-- |+--+-- It is not always required to provide instances for all the generic+-- representation types, but omitting instances restricts the set of+-- datatypes the functions will work for:+--+--    * If no ':+:' instance is given, the function may still work for+--      empty datatypes or datatypes that have a single constructor,+--      but will fail on datatypes with more than one constructor.+--+--    * If no ':*:' instance is given, the function may still work for+--      datatypes where each constructor has just zero or one field,+--      in particular for enumeration types.+--+--    * If no 'K1' instance is given, the function may still work for+--      enumeration types, where no constructor has any fields.+--+--    * If no 'V1' instance is given, the function may still work for+--      any datatype that is not empty.+--+--    * If no 'U1' instance is given, the function may still work for+--      any datatype where each constructor has at least one field.+--+-- An 'M1' instance is always required (but it can just ignore the+-- meta-information, as is the case for @encode@ above).+--+-- ** Generic constructor classes+--+-- |+--+-- Datatype-generic functions as defined above work for a large class+-- of datatypes, including parameterized datatypes. (We have used @Tree@+-- as our example above, which is of kind @* -> *@.) However, the+-- 'Generic' class ranges over types of kind @*@, and therefore, the+-- resulting generic functions (such as @encode@) must be parameterized+-- by a generic type argument of kind @*@.+--+-- What if we want to define generic classes that range over type+-- constructors (such as 'Data.Functor.Functor',+-- 'Data.Traversable.Traversable', or 'Data.Foldable.Foldable')?++-- *** The 'Generic1' class+--+-- |+--+-- Like 'Generic', there is a class 'Generic1' that defines a+-- representation 'Rep1' and conversion functions 'from1' and 'to1',+-- only that 'Generic1' ranges over types of kind @* -> *@. (More generally,+-- it can range over types of kind @k -> *@, for any kind @k@, if the+-- @PolyKinds@ extension is enabled. More on this later.)+-- The 'Generic1' class is also derivable.+--+-- The representation 'Rep1' is ever so slightly different from 'Rep'.+-- Let us look at @Tree@ as an example again:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+--   deriving 'Generic1'+-- @+--+-- The above declaration causes the following representation to be generated:+--+-- @+-- instance 'Generic1' Tree where+--   type 'Rep1' Tree =+--     'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)+--       ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)+--          ('S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--                'Par1')+--        ':+:'+--        'C1' ('MetaCons \"Node\" 'PrefixI 'False)+--          ('S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--                ('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+-- carry around the dummy type argument for kind-@*@-types, but there are+-- already enough different names involved without duplicating each of+-- these.)+--+-- What's different is that we now use 'Par1' to refer to the parameter+-- (and that parameter, which used to be @a@), is not mentioned explicitly+-- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@.++-- *** Representation of @* -> *@ types+--+-- |+--+-- Unlike 'Rec0', the 'Par1' and 'Rec1' type constructors do not+-- map to 'K1'. They are defined directly, as follows:+--+-- @+-- newtype 'Par1'   p = 'Par1' { 'unPar1' ::   p } -- gives access to parameter p+-- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper+-- @+--+-- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply+-- wraps an application of @f@ to @p@.+--+-- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation,+-- namely when the datatype has a field that does not mention the parameter.+--+-- The declaration+--+-- @+-- data WithInt a = WithInt Int a+--   deriving 'Generic1'+-- @+--+-- yields+--+-- @+-- instance 'Generic1' WithInt where+--   type 'Rep1' WithInt =+--     'D1' ('MetaData \"WithInt\" \"Main\" \"package-name\" 'False)+--       ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False)+--         ('S1' ('MetaSel 'Nothing+--                         'NoSourceUnpackedness+--                         'NoSourceStrictness+--                         'DecidedLazy)+--               ('Rec0' Int)+--          ':*:'+--          'S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--               'Par1'))+-- @+--+-- If the parameter @a@ appears underneath a composition of other type constructors,+-- then the representation involves composition, too:+--+-- @+-- data Rose a = Fork a [Rose a]+-- @+--+-- yields+--+-- @+-- instance 'Generic1' Rose where+--   type 'Rep1' Rose =+--     'D1' ('MetaData \"Rose\" \"Main\" \"package-name\" 'False)+--       ('C1' ('MetaCons \"Fork\" 'PrefixI 'False)+--         ('S1' ('MetaSel 'Nothing+--                         'NoSourceUnpackedness+--                         'NoSourceStrictness+--                         'DecidedLazy)+--               'Par1'+--          ':*:'+--          'S1' ('MetaSel 'Nothing+--                          'NoSourceUnpackedness+--                          'NoSourceStrictness+--                          'DecidedLazy)+--               ([] ':.:' 'Rec1' Rose)))+-- @+--+-- where+--+-- @+-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) }+-- @++-- *** Representation of @k -> *@ types+--+-- |+--+-- The 'Generic1' class can be generalized to range over types of kind+-- @k -> *@, for any kind @k@. To do so, derive a 'Generic1' instance with the+-- @PolyKinds@ extension enabled. For example, the declaration+--+-- @+-- data Proxy (a :: k) = Proxy deriving 'Generic1'+-- @+--+-- yields a slightly different instance depending on whether @PolyKinds@ is+-- enabled. If compiled without @PolyKinds@, then @'Rep1' Proxy :: * -> *@, but+-- if compiled with @PolyKinds@, then @'Rep1' Proxy :: k -> *@.++-- *** 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 an unlifted kind, and 'Rec0' expects a type of+-- kind @*@.+--+-- 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.++  -- * Generic representation types+    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, R+  , D1, C1, S1, D, C, S++  -- * Meta-information+  , Datatype(..), Constructor(..), Selector(..)+  , Fixity(..), FixityI(..), Associativity(..), prec+  , SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..)+  , Meta(..)++  -- * Generic type classes+  , Generic(..)+  , Generic1(..)++  -- * Generic wrapper+  , Generically(..)+  , Generically1(..)+  ) where++import GHC.Internal.Generics
+ src/GHC/IO.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.IO+-- Copyright   :  (c) The University of Glasgow 1994-2023+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Definitions for the 'IO' monad and its friends.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO (+        IO(..), unIO, liftIO, mplusIO,+        unsafePerformIO, unsafeInterleaveIO,+        unsafeDupablePerformIO, unsafeDupableInterleaveIO,+        noDuplicate,++        -- To and from ST+        stToIO, ioToST, unsafeIOToST, unsafeSTToIO,++        FilePath,++        catch, catchException, catchAny, throwIO,+        mask, mask_, uninterruptibleMask, uninterruptibleMask_,+        MaskingState(..), getMaskingState,+        unsafeUnmask, interruptible,+        onException, bracket, finally, evaluate,+        mkUserError+    ) where++import GHC.Internal.IO
+ src/GHC/IO/Buffer.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Buffer+-- Copyright   :  (c) The University of Glasgow 2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Buffers used in the IO system+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Buffer+    (-- *  Buffers of any element+     Buffer(..),+     BufferState(..),+     CharBuffer,+     CharBufElem,+     -- **  Creation+     newByteBuffer,+     newCharBuffer,+     newBuffer,+     emptyBuffer,+     -- **  Insertion/removal+     bufferRemove,+     bufferAdd,+     slideContents,+     bufferAdjustL,+     bufferAddOffset,+     bufferAdjustOffset,+     -- **  Inspecting+     isEmptyBuffer,+     isFullBuffer,+     isFullCharBuffer,+     isWriteBuffer,+     bufferElems,+     bufferAvailable,+     bufferOffset,+     summaryBuffer,+     -- **  Operating on the raw buffer as a Ptr+     withBuffer,+     withRawBuffer,+     -- **  Assertions+     checkBuffer,+     -- *  Raw buffers+     RawBuffer,+     readWord8Buf,+     writeWord8Buf,+     RawCharBuffer,+     peekCharBuf,+     readCharBuf,+     writeCharBuf,+     readCharBufPtr,+     writeCharBufPtr,+     charSize+     ) where++import GHC.Internal.IO.Buffer
+ src/GHC/IO/BufferedIO.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.BufferedIO+-- Copyright   :  (c) The University of Glasgow 2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Class of buffered IO devices+--++module GHC.IO.BufferedIO+    (BufferedIO(..),+     readBuf,+     readBufNonBlocking,+     writeBuf,+     writeBufNonBlocking+     ) where++import GHC.Internal.IO.BufferedIO
+ src/GHC/IO/Device.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.IO.Device+-- Copyright   :  (c) The University of Glasgow, 1994-2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Type classes for I/O providers.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Device (+        RawIO(..),+        IODevice(..),+        IODeviceType(..),+        SeekMode(..)+    ) where++import GHC.Internal.IO.Device
+ src/GHC/IO/Encoding.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Encoding+-- Copyright   :  (c) The University of Glasgow, 2008-2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Text codecs for I/O+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Encoding+    (BufferCodec(..),+     TextEncoding(..),+     TextEncoder,+     TextDecoder,+     CodingProgress(..),+     latin1,+     latin1_encode,+     latin1_decode,+     utf8,+     utf8_bom,+     utf16,+     utf16le,+     utf16be,+     utf32,+     utf32le,+     utf32be,+     initLocaleEncoding,+     getLocaleEncoding,+     getFileSystemEncoding,+     getForeignEncoding,+     setLocaleEncoding,+     setFileSystemEncoding,+     setForeignEncoding,+     char8,+     mkTextEncoding,+     argvEncoding+     ) where++import GHC.Internal.IO.Encoding
+ src/GHC/IO/Encoding/CodePage.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}++#if ! defined(mingw32_HOST_OS)++module GHC.IO.Encoding.CodePage ( ) where++-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import Prelude () -- for build ordering++#else++module GHC.IO.Encoding.CodePage+  ( codePageEncoding, mkCodePageEncoding,+    localeEncoding, mkLocaleEncoding, CodePage,+    getCurrentCodePage+  ) where++import GHC.Internal.IO.Encoding.CodePage++#endif
+ src/GHC/IO/Encoding/CodePage/API.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE Safe #-}++module GHC.IO.Encoding.CodePage.API (+    mkCodePageEncoding+  ) where++import GHC.Internal.IO.Encoding.CodePage.API
+ src/GHC/IO/Encoding/CodePage/Table.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE Trustworthy #-}++module GHC.IO.Encoding.CodePage.Table+    ( module GHC.Internal.IO.Encoding.CodePage.Table+    ) where++import GHC.Internal.IO.Encoding.CodePage.Table+
+ src/GHC/IO/Encoding/Failure.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}++-- |+--+-- Module      :  GHC.IO.Encoding.Failure+-- Copyright   :  (c) The University of Glasgow, 2008-2011+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Types for specifying how text encoding/decoding fails+--++module GHC.IO.Encoding.Failure+    (CodingFailureMode(..),+     codingFailureModeSuffix,+     isSurrogate,+     recoverDecode,+     recoverEncode,+     recoverDecode#,+     recoverEncode#+     ) where++import GHC.Internal.IO.Encoding.Failure
+ src/GHC/IO/Encoding/Iconv.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IO.Encoding.Iconv+-- Copyright   :  (c) The University of Glasgow, 2008-2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- This module provides text encoding/decoding using iconv+--++module GHC.IO.Encoding.Iconv+#if !defined(mingw32_HOST_OS)+    (iconvEncoding,+     mkIconvEncoding,+     localeEncodingName+     ) where++import GHC.Internal.IO.Encoding.Iconv++#else+    ( ) where++#endif
+ src/GHC/IO/Encoding/Latin1.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Encoding.Latin1+-- Copyright   :  (c) The University of Glasgow, 2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Single-byte encodings that map directly to Unicode code points.+--+-- Portions Copyright   : (c) Tom Harper 2008-2009,+--                        (c) Bryan O'Sullivan 2009,+--                        (c) Duncan Coutts 2009+--++module GHC.IO.Encoding.Latin1+    (latin1,+     mkLatin1,+     latin1_checked,+     mkLatin1_checked,+     ascii,+     mkAscii,+     latin1_decode,+     ascii_decode,+     latin1_encode,+     latin1_checked_encode,+     ascii_encode+     ) where++import GHC.Internal.IO.Encoding.Latin1
+ src/GHC/IO/Encoding/Types.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+--+-- Module      :  GHC.IO.Encoding.Types+-- Copyright   :  (c) The University of Glasgow, 2008-2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Types for text encoding/decoding+--++module GHC.IO.Encoding.Types+    (BufferCodec(..),+     TextEncoding(..),+     TextEncoder,+     TextDecoder,+     CodeBuffer,+     EncodeBuffer,+     DecodeBuffer,+     CodingProgress(..),+     DecodeBuffer#,+     EncodeBuffer#,+     DecodingBuffer#,+     EncodingBuffer#+     ) where++import GHC.Internal.IO.Encoding.Types
+ src/GHC/IO/Encoding/UTF16.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Encoding.UTF16+-- Copyright   :  (c) The University of Glasgow, 2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- UTF-16 Codecs for the IO library+--+-- Portions Copyright   : (c) Tom Harper 2008-2009,+--                        (c) Bryan O'Sullivan 2009,+--                        (c) Duncan Coutts 2009+--++module GHC.IO.Encoding.UTF16+    (utf16,+     mkUTF16,+     utf16_decode,+     utf16_encode,+     utf16be,+     mkUTF16be,+     utf16be_decode,+     utf16be_encode,+     utf16le,+     mkUTF16le,+     utf16le_decode,+     utf16le_encode+     ) where++import GHC.Internal.IO.Encoding.UTF16
+ src/GHC/IO/Encoding/UTF32.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Encoding.UTF32+-- Copyright   :  (c) The University of Glasgow, 2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- UTF-32 Codecs for the IO library+--+-- Portions Copyright   : (c) Tom Harper 2008-2009,+--                        (c) Bryan O'Sullivan 2009,+--                        (c) Duncan Coutts 2009+--++module GHC.IO.Encoding.UTF32+    (utf32,+     mkUTF32,+     utf32_decode,+     utf32_encode,+     utf32be,+     mkUTF32be,+     utf32be_decode,+     utf32be_encode,+     utf32le,+     mkUTF32le,+     utf32le_decode,+     utf32le_encode+     ) where++import GHC.Internal.IO.Encoding.UTF32
+ src/GHC/IO/Encoding/UTF8.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Encoding.UTF8+-- Copyright   :  (c) The University of Glasgow, 2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- UTF-8 Codec for the IO library+--+-- This is one of several UTF-8 implementations provided by GHC; see Note+-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an+-- overview.+--+-- Portions Copyright   : (c) Tom Harper 2008-2009,+--                        (c) Bryan O'Sullivan 2009,+--                        (c) Duncan Coutts 2009+--++module GHC.IO.Encoding.UTF8+    (utf8,+     mkUTF8,+     utf8_bom,+     mkUTF8_bom+     ) where++import GHC.Internal.IO.Encoding.UTF8
+ src/GHC/IO/Exception.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.IO.Exception+-- Copyright   :  (c) The University of Glasgow, 2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- IO-related Exception types and functions+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Exception (+  BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,+  BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,+  Deadlock(..),+  AllocationLimitExceeded(..), allocationLimitExceeded,+  AssertionFailed(..),+  CompactionFailed(..),+  cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,++  SomeAsyncException(..),+  asyncExceptionToException, asyncExceptionFromException,+  AsyncException(..), stackOverflow, heapOverflow,++  ArrayException(..),+  ExitCode(..),+  FixIOException (..),++  ioException,+  ioError,+  IOError,+  IOException(..),+  IOErrorType(..),+  userError,+  assertError,+  unsupportedOperation,+  untangle,+ ) where++import GHC.Internal.IO.Exception+
+ src/GHC/IO/FD.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IO.FD+-- Copyright   :  (c) The University of Glasgow, 1994-2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Raw read/write operations on file descriptors+--++module GHC.IO.FD+    (FD(..),+     openFileWith,+     openFile,+     mkFD,+     release,+     setNonBlockingMode,+     readRawBufferPtr,+     readRawBufferPtrNoBlock,+     writeRawBufferPtr,+     stdin,+     stdout,+     stderr+     ) where++import GHC.Internal.IO.FD
+ src/GHC/IO/Handle.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Handle+-- Copyright   :  (c) The University of Glasgow, 1994-2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable+--+-- External API for GHC's Handle implementation+--++module GHC.IO.Handle+    (Handle,+     BufferMode(..),+     mkFileHandle,+     mkDuplexHandle,+     hFileSize,+     hSetFileSize,+     hIsEOF,+     isEOF,+     hLookAhead,+     hSetBuffering,+     hSetBinaryMode,+     hSetEncoding,+     hGetEncoding,+     hFlush,+     hFlushAll,+     hDuplicate,+     hDuplicateTo,+     hClose,+     hClose_help,+     LockMode(..),+     hLock,+     hTryLock,+     HandlePosition,+     HandlePosn(..),+     hGetPosn,+     hSetPosn,+     SeekMode(..),+     hSeek,+     hTell,+     hIsOpen,+     hIsClosed,+     hIsReadable,+     hIsWritable,+     hGetBuffering,+     hIsSeekable,+     hSetEcho,+     hGetEcho,+     hIsTerminalDevice,+     hSetNewlineMode,+     Newline(..),+     NewlineMode(..),+     nativeNewline,+     noNewlineTranslation,+     universalNewlineMode,+     nativeNewlineMode,+     hShow,+     hWaitForInput,+     hGetChar,+     hGetLine,+     hGetContents,+     hGetContents',+     hPutChar,+     hPutStr,+     hGetBuf,+     hGetBufNonBlocking,+     hPutBuf,+     hPutBufNonBlocking+     ) where++import GHC.Internal.IO.Handle
+ src/GHC/IO/Handle/FD.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.Handle.FD+-- Copyright   :  (c) The University of Glasgow, 1994-2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Handle operations implemented by file descriptors (FDs)+--+-- @since 4.2.0.0+--++module GHC.IO.Handle.FD+    (stdin,+     stdout,+     stderr,+     openFile,+     withFile,+     openBinaryFile,+     withBinaryFile,+     openFileBlocking,+     withFileBlocking,+     mkHandleFromFD,+     fdToHandle,+     fdToHandle',+     handleToFd+     ) where++import GHC.Internal.IO.Handle.FD
+ src/GHC/IO/Handle/Internals.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IO.Handle.Internals+-- Copyright   :  (c) The University of Glasgow, 1994-2001+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- This module defines the basic operations on I\/O \"handles\".  All+-- of the operations defined here are independent of the underlying+-- device.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Handle.Internals+    (withHandle,+     withHandle',+     withHandle_,+     withHandle__',+     withHandle_',+     withAllHandles__,+     wantWritableHandle,+     wantReadableHandle,+     wantReadableHandle_,+     wantSeekableHandle,+     mkHandle,+     mkFileHandle,+     mkFileHandleNoFinalizer,+     mkDuplexHandle,+     mkDuplexHandleNoFinalizer,+     addHandleFinalizer,+     openTextEncoding,+     closeTextCodecs,+     initBufferState,+     dEFAULT_CHAR_BUFFER_SIZE,+     flushBuffer,+     flushWriteBuffer,+     flushCharReadBuffer,+     flushCharBuffer,+     flushByteReadBuffer,+     flushByteWriteBuffer,+     readTextDevice,+     writeCharBuffer,+     readTextDeviceNonBlocking,+     decodeByteBuf,+     augmentIOError,+     ioe_closedHandle,+     ioe_semiclosedHandle,+     ioe_EOF,+     ioe_notReadable,+     ioe_notWritable,+     ioe_finalizedHandle,+     ioe_bufsiz,+     hClose_impl,+     hClose_help,+     hLookAhead_,+     HandleFinalizer,+     handleFinalizer,+     debugIO,+     traceIO+     ) where++import GHC.Internal.IO.Handle.Internals
+ src/GHC/IO/Handle/Lock.hs view
@@ -0,0 +1,9 @@+module GHC.IO.Handle.Lock+    (FileLockingNotSupported(..),+     LockMode(..),+     hLock,+     hTryLock,+     hUnlock+     ) where++import GHC.Internal.IO.Handle.Lock
+ src/GHC/IO/Handle/Text.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.IO.Handle.Text+-- Copyright   :  (c) The University of Glasgow, 1992-2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- String I\/O functions+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Handle.Text (+        hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,+        commitBuffer',       -- hack, see below+        hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,+        memcpy, hPutStrLn, hGetContents',+    ) where++import GHC.Internal.IO.Handle.Text
+ src/GHC/IO/Handle/Types.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.IO.Handle.Types+-- Copyright   :  (c) The University of Glasgow, 1994-2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Basic types for the implementation of IO Handles.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.Handle.Types (+      Handle(..), Handle__(..), showHandle,+      checkHandleInvariants,+      BufferList(..),+      HandleType(..),+      isReadableHandleType, isWritableHandleType, isReadWriteHandleType,+      isAppendHandleType,+      BufferMode(..),+      BufferCodec(..),+      NewlineMode(..), Newline(..), nativeNewline,+      universalNewlineMode, noNewlineTranslation, nativeNewlineMode+  ) where++import GHC.Internal.IO.Handle.Types
+ src/GHC/IO/Handle/Windows.hs view
@@ -0,0 +1,20 @@+-- |+-- Module      :  GHC.IO.Handle.Windows+-- Copyright   :  (c) The University of Glasgow, 2017+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Handle operations implemented by Windows native handles+--+-----------------------------------------------------------------------------++module GHC.IO.Handle.Windows (+  stdin, stdout, stderr,+  openFile, openBinaryFile, openFileBlocking,+  handleToHANDLE, mkHandleFromHANDLE+ ) where++import GHC.Internal.IO.Handle.Windows
+ src/GHC/IO/IOMode.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IO.IOMode+-- Copyright   :  (c) The University of Glasgow, 1994-2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- The IOMode type+--++module GHC.IO.IOMode+    (IOMode(..)+     ) where++import GHC.Internal.IO.IOMode
+ src/GHC/IO/StdHandles.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.StdHandles+-- Copyright   :  (c) The University of Glasgow, 2017+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- This model abstracts away the platform specific handles that can be toggled+-- through the RTS.+--++module GHC.IO.StdHandles+    (stdin,+     stdout,+     stderr,+     openFile,+     openBinaryFile,+     openFileBlocking,+     withFile,+     withBinaryFile,+     withFileBlocking+     ) where++import GHC.Internal.IO.StdHandles
+ src/GHC/IO/SubSystem.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IO.SubSystem+-- Copyright   :  (c) The University of Glasgow, 2017+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- The 'IoSubSystem' control interface.  These methods can be used to disambiguate+-- between the two operations.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.IO.SubSystem+    (withIoSubSystem,+     withIoSubSystem',+     whenIoSubSystem,+     ioSubSystem,+     IoSubSystem(..),+     conditional,+     (<!>),+     isWindowsNativeIO+     ) where++import GHC.Internal.IO.SubSystem
+ src/GHC/IO/Unsafe.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IO.Unsafe+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Unsafe IO operations+--++module GHC.IO.Unsafe+    (unsafePerformIO,+     unsafeInterleaveIO,+     unsafeDupablePerformIO,+     unsafeDupableInterleaveIO,+     noDuplicate+     ) where++import GHC.Internal.IO.Unsafe
+ src/GHC/IO/Windows/Encoding.hs view
@@ -0,0 +1,25 @@+-- |+-- Module      :  System.Win32.Encoding+-- Copyright   :  2012 shelarcy+-- License     :  BSD-style+--+-- Maintainer  :  shelarcy@gmail.com+-- Stability   :  Provisional+-- Portability :  Non-portable (Win32 API)+--+-- Encode/Decode multibyte character using Win32 API.+--++module GHC.IO.Windows.Encoding+  ( encodeMultiByte+  , encodeMultiByteIO+  , encodeMultiByteRawIO+  , decodeMultiByte+  , decodeMultiByteIO+  , wideCharToMultiByte+  , multiByteToWideChar+  , withGhcInternalToUTF16+  , withUTF16ToGhcInternal+  ) where++import GHC.Internal.IO.Windows.Encoding
+ src/GHC/IO/Windows/Handle.hs view
@@ -0,0 +1,40 @@+-- |+-- Module      :  GHC.IO.Windows.Handle+-- Copyright   :  (c) The University of Glasgow, 2017+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Raw read/write operations on Windows Handles+--++module GHC.IO.Windows.Handle+ ( -- * Basic Types+   NativeHandle(),+   ConsoleHandle(),+   IoHandle(),+   HANDLE,+   Io(),++   -- * Utility functions+   convertHandle,+   toHANDLE,+   fromHANDLE,+   handleToMode,+   isAsynchronous,+   optimizeFileAccess,++   -- * Standard Handles+   stdin,+   stdout,+   stderr,++   -- * File utilities+   openFile,+   openFileAsTemp,+   release+ ) where++import GHC.Internal.IO.Windows.Handle
+ src/GHC/IO/Windows/Paths.hs view
@@ -0,0 +1,18 @@+-- |+-- Module      :  GHC.IO.Windows.Paths+-- Copyright   :  (c) The University of Glasgow, 2017+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Windows FilePath handling utility for GHC code.+--+-----------------------------------------------------------------------------++module GHC.IO.Windows.Paths+   ( getDevicePath+   ) where++import GHC.Internal.IO.Windows.Paths
+ src/GHC/IOArray.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IOArray+-- Copyright   :  (c) The University of Glasgow 2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The IOArray type+--++module GHC.IOArray+    (IOArray(..),+     newIOArray,+     unsafeReadIOArray,+     unsafeWriteIOArray,+     readIOArray,+     writeIOArray,+     boundsIOArray+     ) where++import GHC.Internal.IOArray
+ src/GHC/IORef.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.IORef+-- Copyright   :  (c) The University of Glasgow 2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The IORef type+--++module GHC.IORef+    (IORef(..),+     newIORef,+     readIORef,+     writeIORef,+     atomicModifyIORef2Lazy,+     atomicModifyIORef2,+     atomicModifyIORefLazy_,+     atomicModifyIORef'_,+     atomicModifyIORefP,+     atomicSwapIORef,+     atomicModifyIORef'+     ) where++import GHC.Internal.IORef
+ src/GHC/InfoProv.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.InfoProv+-- Copyright   :  (c) The University of Glasgow 2011+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Access to GHC's info-table provenance metadata.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--+-- @since 4.18.0.0+--++module GHC.InfoProv+    ( InfoProv(..)+    , ipLoc+    , ipeProv+    , whereFrom+      -- * Internals+    , InfoProvEnt+    , peekInfoProv+    ) where++import GHC.Internal.InfoProv
+ src/GHC/Int.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Int+-- Copyright   :  (c) The University of Glasgow 1997-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The sized integral datatypes, 'Int8', 'Int16', 'Int32', and 'Int64'.+--++module GHC.Int+    (Int(..),+     Int8(..),+     Int16(..),+     Int32(..),+     Int64(..),+     uncheckedIShiftL64#,+     uncheckedIShiftRA64#,+     shiftRLInt8#,+     shiftRLInt16#,+     shiftRLInt32#,+     -- *  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 GHC.Internal.Int
+ src/GHC/Integer.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Compatibility module for pre-@ghc-bignum@ code.++module GHC.Integer+    (Integer,+     -- *  Construct 'Integer's+     smallInteger,+     wordToInteger,+     -- *  Conversion to other integral types+     integerToWord,+     integerToInt,+     -- *  Helpers for 'RealFloat' type-class operations+     encodeFloatInteger,+     encodeDoubleInteger,+     decodeDoubleInteger,+     -- *  Arithmetic operations+     plusInteger,+     minusInteger,+     timesInteger,+     negateInteger,+     absInteger,+     signumInteger,+     divModInteger,+     divInteger,+     modInteger,+     quotRemInteger,+     quotInteger,+     remInteger,+     -- *  Comparison predicates+     eqInteger,+     neqInteger,+     leInteger,+     gtInteger,+     ltInteger,+     geInteger,+     compareInteger,+     -- **  'Int#'-boolean valued versions of comparison predicates+     -- |  These operations return @0#@ and @1#@ instead of 'False' and+     -- 'True' respectively.  See+     -- <https://gitlab.haskell.org/ghc/ghc/wikis/prim-bool PrimBool wiki-page>+     -- for more details+     eqInteger#,+     neqInteger#,+     leInteger#,+     gtInteger#,+     ltInteger#,+     geInteger#,+     -- *  Bit-operations+     andInteger,+     orInteger,+     xorInteger,+     complementInteger,+     shiftLInteger,+     shiftRInteger,+     testBitInteger,+     popCountInteger,+     bitInteger,+     -- *  Hashing+     hashInteger+     ) where++import GHC.Internal.Integer
+ src/GHC/Integer/Logarithms.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MagicHash #-}++-- |+-- Compatibility module for pre-@ghc-bignum@ code.++module GHC.Integer.Logarithms+    (wordLog2#,+     integerLog2#,+     integerLogBase#+     ) where++import GHC.Internal.Integer.Logarithms
+ src/GHC/IsList.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.IsList+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- @since 4.17.0.0++module GHC.IsList+    (IsList(..)+     ) where++import GHC.Internal.IsList
+ src/GHC/Ix.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Ix+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- GHC\'s Ix typeclass implementation.+--++module GHC.Ix+    (Ix(..),+     indexError+     ) where++import GHC.Internal.Ix
+ src/GHC/JS/Foreign/Callback.hs view
@@ -0,0 +1,22 @@+module GHC.JS.Foreign.Callback+    ( Callback+    , OnBlocked(..)+    , releaseCallback+      -- * asynchronous callbacks+    , asyncCallback+    , asyncCallback1+    , asyncCallback2+    , asyncCallback3+      -- * synchronous callbacks+    , syncCallback+    , syncCallback1+    , syncCallback2+    , syncCallback3+      -- * synchronous callbacks that return a value+    , syncCallback'+    , syncCallback1'+    , syncCallback2'+    , syncCallback3'+    ) where++import GHC.Internal.JS.Foreign.Callback
+ src/GHC/JS/Prim.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++module GHC.JS.Prim+    ( JSVal(..), JSVal#+    , JSException(..)+    , WouldBlockException(..)+#if defined(javascript_HOST_ARCH)+    , toIO+    , resolve+    , resolveIO+    , mkJSException+    , fromJSString+    , toJSString+    , toJSArray+    , fromJSArray+    , fromJSInt+    , toJSInt+    , isNull+    , isUndefined+    , jsNull+    , getProp+    , getProp'+    , getProp#+    , unsafeGetProp+    , unsafeGetProp'+    , unsafeGetProp#+    , unpackJSString#+    , unpackJSStringUtf8#+    , unsafeUnpackJSString#+    , unsafeUnpackJSStringUtf8#+    , unpackJSStringUtf8##+    , unsafeUnpackJSStringUtf8##+#endif+    ) where++import GHC.Internal.JS.Prim+
+ src/GHC/JS/Prim/Internal.hs view
@@ -0,0 +1,10 @@+module GHC.JS.Prim.Internal+    ( blockedIndefinitelyOnMVar+    , blockedIndefinitelyOnSTM+    , wouldBlock+    , ignoreException+    , setCurrentThreadResultException+    , setCurrentThreadResultValue+    ) where++import GHC.Internal.JS.Prim.Internal
+ src/GHC/JS/Prim/Internal/Build.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}++module GHC.JS.Prim.Internal.Build+  {-# DEPRECATED "Use ghc-internal:GHC.Internal.JS.Prim.Internal.Build instead" #-}+  -- deprecated for now. To be fully removed in GHC 9.16+  -- see https://github.com/haskell/core-libraries-committee/issues/329 and #23432+#if !defined(javascript_HOST_ARCH)+  () where+#else+  ( buildArrayI+  , buildArrayM+  , buildObjectI+  , buildObjectM+  , buildArrayI1+  , buildArrayI2+  , buildArrayI3+  , buildArrayI4+  , buildArrayI5+  , buildArrayI6+  , buildArrayI7+  , buildArrayI8+  , buildArrayI9+  , buildArrayI10+  , buildArrayI11+  , buildArrayI12+  , buildArrayI13+  , buildArrayI14+  , buildArrayI15+  , buildArrayI16+  , buildArrayI17+  , buildArrayI18+  , buildArrayI19+  , buildArrayI20+  , buildArrayI21+  , buildArrayI22+  , buildArrayI23+  , buildArrayI24+  , buildArrayI25+  , buildArrayI26+  , buildArrayI27+  , buildArrayI28+  , buildArrayI29+  , buildArrayI30+  , buildArrayI31+  , buildArrayI32+  , buildArrayM1+  , buildArrayM2+  , buildArrayM3+  , buildArrayM4+  , buildArrayM5+  , buildArrayM6+  , buildArrayM7+  , buildArrayM8+  , buildArrayM9+  , buildArrayM10+  , buildArrayM11+  , buildArrayM12+  , buildArrayM13+  , buildArrayM14+  , buildArrayM15+  , buildArrayM16+  , buildArrayM17+  , buildArrayM18+  , buildArrayM19+  , buildArrayM20+  , buildArrayM21+  , buildArrayM22+  , buildArrayM23+  , buildArrayM24+  , buildArrayM25+  , buildArrayM26+  , buildArrayM27+  , buildArrayM28+  , buildArrayM29+  , buildArrayM30+  , buildArrayM31+  , buildArrayM32+  , buildObjectI1+  , buildObjectI2+  , buildObjectI3+  , buildObjectI4+  , buildObjectI5+  , buildObjectI6+  , buildObjectI7+  , buildObjectI8+  , buildObjectI9+  , buildObjectI10+  , buildObjectI11+  , buildObjectI12+  , buildObjectI13+  , buildObjectI14+  , buildObjectI15+  , buildObjectI16+  , buildObjectI17+  , buildObjectI18+  , buildObjectI19+  , buildObjectI20+  , buildObjectI21+  , buildObjectI22+  , buildObjectI23+  , buildObjectI24+  , buildObjectI25+  , buildObjectI26+  , buildObjectI27+  , buildObjectI28+  , buildObjectI29+  , buildObjectI30+  , buildObjectI31+  , buildObjectI32+  , buildObjectM1+  , buildObjectM2+  , buildObjectM3+  , buildObjectM4+  , buildObjectM5+  , buildObjectM6+  , buildObjectM7+  , buildObjectM8+  , buildObjectM9+  , buildObjectM10+  , buildObjectM11+  , buildObjectM12+  , buildObjectM13+  , buildObjectM14+  , buildObjectM15+  , buildObjectM16+  , buildObjectM17+  , buildObjectM18+  , buildObjectM19+  , buildObjectM20+  , buildObjectM21+  , buildObjectM22+  , buildObjectM23+  , buildObjectM24+  , buildObjectM25+  , buildObjectM26+  , buildObjectM27+  , buildObjectM28+  , buildObjectM29+  , buildObjectM30+  , buildObjectM31+  , buildObjectM32+  ) where++import GHC.Internal.JS.Prim.Internal.Build++#endif+
+ src/GHC/List.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE Safe #-}+++-- |+--+-- Module      :  GHC.List+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The List data type and its operations+--++module GHC.List (++   -- * The list data type+   List,++   -- * List-monomorphic Foldable methods and misc functions+   foldr, foldr', foldr1,+   foldl, foldl', foldl1,+   null, length, elem, notElem,+   maximum, minimum, sum, product, and, or, any, all,++   -- * Other functions+   foldl1', concat, concatMap,+   map, (++), filter, lookup,+   head, last, tail, init, uncons, unsnoc, (!?), (!!),+   scanl, scanl1, scanl', scanr, scanr1,+   iterate, iterate', repeat, replicate, cycle,+   take, drop, splitAt, takeWhile, dropWhile, span, break, reverse,+   zip, zip3, zipWith, zipWith3, unzip, unzip3,+   errorEmptyList,++   -- * GHC List fusion+   augment, build,++ ) where++import GHC.Internal.List
+ src/GHC/MVar.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.MVar+-- Copyright   :  (c) The University of Glasgow 2008+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The MVar type+--++module GHC.MVar+    (-- *  MVars+     MVar(..),+     newMVar,+     newEmptyMVar,+     takeMVar,+     readMVar,+     putMVar,+     tryTakeMVar,+     tryPutMVar,+     tryReadMVar,+     isEmptyMVar,+     addMVarFinalizer+     ) where++import GHC.Internal.MVar
+ src/GHC/Maybe.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Maybe+-- Copyright   :  (c) The University of Glasgow 1997-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Maybe' type.++module GHC.Maybe+    (Maybe(..)) where++import GHC.Internal.Maybe
+ src/GHC/Natural.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Compatibility module for pre ghc-bignum code.++module GHC.Natural+    (Natural(NatS#, NatJ#),+     BigNat(..),+     mkNatural,+     isValidNatural,+     -- *  Arithmetic+     plusNatural,+     minusNatural,+     minusNaturalMaybe,+     timesNatural,+     negateNatural,+     signumNatural,+     quotRemNatural,+     quotNatural,+     remNatural,+     gcdNatural,+     lcmNatural,+     -- *  Bits+     andNatural,+     orNatural,+     xorNatural,+     bitNatural,+     testBitNatural,+     popCountNatural,+     shiftLNatural,+     shiftRNatural,+     -- *  Conversions+     naturalToInteger,+     naturalToWord,+     naturalToWordMaybe,+     wordToNatural,+     wordToNatural#,+     naturalFromInteger,+     -- *  Modular arithmetic+     powModNatural+     ) where++import GHC.Internal.Natural
+ src/GHC/Num.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Num+-- Copyright   :  (c) The University of Glasgow 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Num' class and the 'Integer' type.+--++module GHC.Num+   ( Num(..)+   , subtract+   , quotRemInteger+   , module GHC.Num.Integer+   , module GHC.Num.Natural+   )+where++import GHC.Internal.Num+import GHC.Num.Integer+import GHC.Num.Natural
+ src/GHC/Num/BigNat.hs view
@@ -0,0 +1,6 @@+module GHC.Num.BigNat+  ( module GHC.Internal.Bignum.BigNat+  )+where++import GHC.Internal.Bignum.BigNat
+ src/GHC/Num/Integer.hs view
@@ -0,0 +1,6 @@+module GHC.Num.Integer+  ( module GHC.Internal.Bignum.Integer+  )+where++import GHC.Internal.Bignum.Integer
+ src/GHC/Num/Natural.hs view
@@ -0,0 +1,6 @@+module GHC.Num.Natural+  ( module GHC.Internal.Bignum.Natural+  )+where++import GHC.Internal.Bignum.Natural
+ src/GHC/OldList.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.OldList+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- This legacy module provides access to the list-specialised operations+-- of "Data.List". This module may go away again in future GHC versions and+-- is provided as transitional tool to access some of the list-specialised+-- operations that had to be generalised due to the implementation of the+-- <https://wiki.haskell.org/Foldable_Traversable_In_Prelude Foldable/Traversable-in-Prelude Proposal (FTP)>.+--+-- If the operations needed are available in "GHC.List", it's+-- recommended to avoid importing this module and use "GHC.List"+-- instead for now.+--+-- @since 4.8.0.0++module GHC.OldList (module GHC.Internal.Data.OldList) where++import GHC.Internal.Data.OldList
+ src/GHC/OverloadedLabels.hs view
@@ -0,0 +1,32 @@+-- |+--+-- Module      :  GHC.OverloadedLabels+-- Copyright   :  (c) Adam Gundry 2015-2016+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- This module defines the 'IsLabel' class used by the+-- @OverloadedLabels@ extension.  See the+-- <https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields/overloaded-labels wiki page>+-- for more details.+--+-- When @OverloadedLabels@ is enabled, if GHC sees an occurrence of+-- the overloaded label syntax @#foo@, it is replaced with+--+-- > fromLabel @"foo" :: alpha+--+-- plus a wanted constraint @IsLabel "foo" alpha@.+--+-- Note that if @RebindableSyntax@ is enabled, the desugaring of+-- overloaded label syntax will make use of whatever @fromLabel@ is in+-- scope.+--++module GHC.OverloadedLabels+    (IsLabel(..)+     ) where++import GHC.Internal.OverloadedLabels
+ src/GHC/Profiling.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE Safe #-}++-- |+-- @since 4.7.0.0++module GHC.Profiling+    (-- *  Cost Centre Profiling+     startProfTimer,+     stopProfTimer,+     -- *  Heap Profiling+     startHeapProfTimer,+     stopHeapProfTimer,+     requestHeapCensus+     ) where++import GHC.Internal.Profiling
+ src/GHC/Ptr.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Ptr+-- Copyright   :  (c) The FFI Task Force, 2000-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Ptr' and 'FunPtr' types and operations.+--++module GHC.Ptr (+        Ptr(..), FunPtr(..),+        nullPtr, castPtr, plusPtr, alignPtr, minusPtr,+        nullFunPtr, castFunPtr,++        -- * Unsafe functions+        castFunPtrToPtr, castPtrToFunPtr,+    ) where++import GHC.Internal.Ptr
+ src/GHC/RTS/Flags.hs view
@@ -0,0 +1,474 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module      :  GHC.RTS.Flags+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- /The API of this module is unstable and is tightly coupled to GHC's internals./+-- If depend on it, make sure to use a tight upper bound, e.g., @base < 4.X@ rather+-- than @base < 5@, because the interface can change rapidly without much warning.+--+-- Descriptions of flags can be seen in+-- <https://www.haskell.org/ghc/docs/latest/html/users_guide/runtime_control.html GHC User's Guide>,+-- or by running RTS help message using @+RTS --help@.+--+-- @since 4.8.0.0+--+-- This module is a compatibility layer. It is meant to be temporary to allow for the eventual deprecation of these declarations as described in [CLC proposal #289](https://github.com/haskell/core-libraries-committee/issues/289). These declarations are now instead available from the @ghc-experimental@ package.++module GHC.RTS.Flags+  ( RtsTime+  , RTSFlags (..)+  , GiveGCStats (..)+  , GCFlags (..)+  , ConcFlags (..)+  , MiscFlags (..)+  , IoManagerFlag (..)+  , DebugFlags (..)+  , DoCostCentres (..)+  , CCFlags (..)+  , DoHeapProfile (..)+  , ProfFlags (..)+  , DoTrace (..)+  , TraceFlags (..)+  , TickyFlags (..)+  , ParFlags (..)+  , HpcFlags (..)+  , {-# DEPRECATED "import GHC.IO.SubSystem (IoSubSystem (..))" #-}+    IoSubSystem (..)+  , getRTSFlags+  , getGCFlags+  , getConcFlags+  , getMiscFlags+  , getDebugFlags+  , getCCFlags+  , getProfFlags+  , getTraceFlags+  , getTickyFlags+  , getParFlags+  , getHpcFlags+  ) where++import Prelude (Show,IO,Bool,Maybe,String,Int,Enum,FilePath,Double,Eq,(<$>))++import GHC.Generics (Generic)+import qualified GHC.Internal.RTS.Flags as Internal+import GHC.Internal.IO.SubSystem (IoSubSystem(..))++import Data.Word (Word32,Word64,Word)++-- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@+--+-- @since base-4.8.2.0+type RtsTime = Word64++-- | Should we produce a summary of the garbage collector statistics after the+-- program has exited?+--+-- @since base-4.8.2.0+data GiveGCStats+    = NoGCStats+    | CollectGCStats+    | OneLineGCStats+    | SummaryGCStats+    | VerboseGCStats+    deriving ( Show -- ^ @since base-4.8.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++-- | Parameters of the garbage collector.+--+-- @since base-4.8.0.0+data GCFlags = GCFlags+    { statsFile             :: Maybe FilePath+    , giveStats             :: GiveGCStats+    , maxStkSize            :: Word32+    , initialStkSize        :: Word32+    , stkChunkSize          :: Word32+    , stkChunkBufferSize    :: Word32+    , maxHeapSize           :: Word32+    , minAllocAreaSize      :: Word32+    , largeAllocLim         :: Word32+    , nurseryChunkSize      :: Word32+    , minOldGenSize         :: Word32+    , heapSizeSuggestion    :: Word32+    , heapSizeSuggestionAuto :: Bool+    , oldGenFactor          :: Double+    , returnDecayFactor     :: Double+    , pcFreeHeap            :: Double+    , generations           :: Word32+    , squeezeUpdFrames      :: Bool+    , compact               :: Bool -- ^ True <=> "compact all the time"+    , compactThreshold      :: Double+    , sweep                 :: Bool+      -- ^ use "mostly mark-sweep" instead of copying for the oldest generation+    , ringBell              :: Bool+    , idleGCDelayTime       :: RtsTime+    , doIdleGC              :: Bool+    , heapBase              :: Word -- ^ address to ask the OS for memory+    , allocLimitGrace       :: Word+    , numa                  :: Bool+    , numaMask              :: Word+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | Parameters concerning context switching+--+-- @since base-4.8.0.0+data ConcFlags = ConcFlags+    { ctxtSwitchTime  :: RtsTime+    , ctxtSwitchTicks :: Int+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | Miscellaneous parameters+--+-- @since base-4.8.0.0+data MiscFlags = MiscFlags+    { tickInterval          :: RtsTime+    , installSignalHandlers :: Bool+    , installSEHHandlers    :: Bool+    , generateCrashDumpFile :: Bool+    , generateStackTrace    :: Bool+    , machineReadable       :: Bool+    , disableDelayedOsMemoryReturn :: Bool+    , internalCounters      :: Bool+    , linkerAlwaysPic       :: Bool+    , linkerMemBase         :: Word+      -- ^ address to ask the OS for memory for the linker, 0 ==> off+    , ioManager             :: IoManagerFlag+    , numIoWorkerThreads    :: Word32+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- |+--+-- @since base-4.21.0.0+data IoManagerFlag =+       IoManagerFlagAuto+     | IoManagerFlagSelect        -- ^ Unix only, non-threaded RTS only+     | IoManagerFlagMIO           -- ^ cross-platform, threaded RTS only+     | IoManagerFlagWinIO         -- ^ Windows only+     | IoManagerFlagWin32Legacy   -- ^ Windows only, non-threaded RTS only+  deriving (Eq, Enum, Show)++-- | Flags to control debugging output & extra checking in various+-- subsystems.+--+-- @since base-4.8.0.0+data DebugFlags = DebugFlags+    { scheduler      :: Bool -- ^ @s@+    , interpreter    :: Bool -- ^ @i@+    , weak           :: Bool -- ^ @w@+    , gccafs         :: Bool -- ^ @G@+    , gc             :: Bool -- ^ @g@+    , nonmoving_gc   :: Bool -- ^ @n@+    , block_alloc    :: Bool -- ^ @b@+    , sanity         :: Bool -- ^ @S@+    , stable         :: Bool -- ^ @t@+    , prof           :: Bool -- ^ @p@+    , linker         :: Bool -- ^ @l@ the object linker+    , apply          :: Bool -- ^ @a@+    , stm            :: Bool -- ^ @m@+    , squeeze        :: Bool -- ^ @z@ stack squeezing & lazy blackholing+    , hpc            :: Bool -- ^ @c@ coverage+    , sparks         :: Bool -- ^ @r@+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | Should the RTS produce a cost-center summary?+--+-- @since base-4.8.2.0+data DoCostCentres+    = CostCentresNone+    | CostCentresSummary+    | CostCentresVerbose+    | CostCentresAll+    | CostCentresJSON+    deriving ( Show -- ^ @since base-4.8.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++-- | Parameters pertaining to the cost-center profiler.+--+-- @since base-4.8.0.0+data CCFlags = CCFlags+    { doCostCentres :: DoCostCentres+    , profilerTicks :: Int+    , msecsPerTick  :: Int+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | What sort of heap profile are we collecting?+--+-- @since base-4.8.2.0+data DoHeapProfile+    = NoHeapProfiling+    | HeapByCCS+    | HeapByMod+    | HeapByDescr+    | HeapByType+    | HeapByRetainer+    | HeapByLDV+    | HeapByClosureType+    | HeapByInfoTable+    | HeapByEra -- ^ @since base-4.20.0.0+    deriving ( Show -- ^ @since base-4.8.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++-- | Parameters of the cost-center profiler+--+-- @since base-4.8.0.0+data ProfFlags = ProfFlags+    { doHeapProfile            :: DoHeapProfile+    , heapProfileInterval      :: RtsTime -- ^ time between samples+    , heapProfileIntervalTicks :: Word    -- ^ ticks between samples (derived)+    , startHeapProfileAtStartup :: Bool+    , startTimeProfileAtStartup :: Bool   -- ^ @since base-4.20.0.0+    , showCCSOnException       :: Bool+    , automaticEraIncrement    :: Bool   -- ^ @since 4.20.0.0+    , maxRetainerSetSize       :: Word+    , ccsLength                :: Word+    , modSelector              :: Maybe String+    , descrSelector            :: Maybe String+    , typeSelector             :: Maybe String+    , ccSelector               :: Maybe String+    , ccsSelector              :: Maybe String+    , retainerSelector         :: Maybe String+    , bioSelector              :: Maybe String+    , eraSelector              :: Word -- ^ @since base-4.20.0.0+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | Is event tracing enabled?+--+-- @since base-4.8.2.0+data DoTrace+    = TraceNone      -- ^ no tracing+    | TraceEventLog  -- ^ send tracing events to the event log+    | TraceStderr    -- ^ send tracing events to @stderr@+    deriving ( Show -- ^ @since base-4.8.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++-- | Parameters pertaining to event tracing+--+-- @since base-4.8.0.0+data TraceFlags = TraceFlags+    { tracing        :: DoTrace+    , timestamp      :: Bool -- ^ show timestamp in stderr output+    , traceScheduler :: Bool -- ^ trace scheduler events+    , traceGc        :: Bool -- ^ trace GC events+    , traceNonmovingGc+                     :: Bool -- ^ trace nonmoving GC heap census samples+    , sparksSampled  :: Bool -- ^ trace spark events by a sampled method+    , sparksFull     :: Bool -- ^ trace spark events 100% accurately+    , user           :: Bool -- ^ trace user events (emitted from Haskell code)+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | Parameters pertaining to ticky-ticky profiler+--+-- @since base-4.8.0.0+data TickyFlags = TickyFlags+    { showTickyStats :: Bool+    , tickyFile      :: Maybe FilePath+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-- | Parameters pertaining to parallelism+--+-- @since base-4.8.0.0+data ParFlags = ParFlags+    { nCapabilities             :: Word32+    , migrate                   :: Bool+    , maxLocalSparks            :: Word32+    , parGcEnabled              :: Bool+    , parGcGen                  :: Word32+    , parGcLoadBalancingEnabled :: Bool+    , parGcLoadBalancingGen     :: Word32+    , parGcNoSyncWithIdle       :: Word32+    , parGcThreads              :: Word32+    , setAffinity               :: Bool+    }+    deriving ( Show -- ^ @since base-4.8.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++-- | Parameters pertaining to Haskell program coverage (HPC)+--+-- @since base-4.20.0.0+data HpcFlags = HpcFlags+    { readTixFile :: Bool+      -- ^ Controls whether a @<program>.tix@ file is read at+      -- the start of execution to initialize the RTS internal+      -- HPC datastructures.+    , writeTixFile :: Bool+      -- ^ Controls whether the @<program>.tix@ file should be+      -- written after the execution of the program.+    }+    deriving (Show -- ^ @since base-4.20.0.0+             , Generic -- ^ @since base-4.20.0.0+             )+-- | Parameters of the runtime system+--+-- @since base-4.8.0.0+data RTSFlags = RTSFlags+    { gcFlags         :: GCFlags+    , concurrentFlags :: ConcFlags+    , miscFlags       :: MiscFlags+    , debugFlags      :: DebugFlags+    , costCentreFlags :: CCFlags+    , profilingFlags  :: ProfFlags+    , traceFlags      :: TraceFlags+    , tickyFlags      :: TickyFlags+    , parFlags        :: ParFlags+    , hpcFlags        :: HpcFlags+    } deriving ( Show -- ^ @since base-4.8.0.0+               , Generic -- ^ @since base-4.15.0.0+               )++-------------------------------- compat ----------------------------------------++internal_to_base_RTSFlags :: Internal.RTSFlags -> RTSFlags+internal_to_base_RTSFlags Internal.RTSFlags{..} =+  RTSFlags{ gcFlags         = internal_to_base_GCFlags    gcFlags+          , concurrentFlags = internal_to_base_ConcFlags  concurrentFlags+          , miscFlags       = internal_to_base_MiscFlags  miscFlags+          , debugFlags      = internal_to_base_DebugFlags debugFlags+          , costCentreFlags = internal_to_base_CCFlags    costCentreFlags+          , profilingFlags  = internal_to_base_ProfFlags  profilingFlags+          , traceFlags      = internal_to_base_TraceFlags traceFlags+          , tickyFlags      = internal_to_base_TickyFlags tickyFlags+          , parFlags        = internal_to_base_ParFlags   parFlags+          , hpcFlags        = internal_to_base_HpcFlags   hpcFlags+          }++internal_to_base_GCFlags :: Internal.GCFlags -> GCFlags+internal_to_base_GCFlags i@Internal.GCFlags{..} =+  let give_stats = internal_to_base_giveStats (Internal.giveStats i)+  in GCFlags{ giveStats = give_stats, .. }+  where+    internal_to_base_giveStats :: Internal.GiveGCStats -> GiveGCStats+    internal_to_base_giveStats Internal.NoGCStats      = NoGCStats+    internal_to_base_giveStats Internal.CollectGCStats = CollectGCStats+    internal_to_base_giveStats Internal.OneLineGCStats = OneLineGCStats+    internal_to_base_giveStats Internal.SummaryGCStats = SummaryGCStats+    internal_to_base_giveStats Internal.VerboseGCStats = VerboseGCStats++internal_to_base_ParFlags :: Internal.ParFlags -> ParFlags+internal_to_base_ParFlags Internal.ParFlags{..} = ParFlags{..}++internal_to_base_HpcFlags :: Internal.HpcFlags -> HpcFlags+internal_to_base_HpcFlags Internal.HpcFlags{..} = HpcFlags{..}++internal_to_base_ConcFlags :: Internal.ConcFlags -> ConcFlags+internal_to_base_ConcFlags Internal.ConcFlags{..} = ConcFlags{..}++internal_to_base_MiscFlags :: Internal.MiscFlags -> MiscFlags+internal_to_base_MiscFlags i@Internal.MiscFlags{..} =+  let io_manager = internal_to_base_ioManager (Internal.ioManager i)+  in MiscFlags{ ioManager = io_manager, ..}+  where+    internal_to_base_ioManager :: Internal.IoManagerFlag -> IoManagerFlag+    internal_to_base_ioManager Internal.IoManagerFlagAuto        = IoManagerFlagAuto+    internal_to_base_ioManager Internal.IoManagerFlagSelect      = IoManagerFlagSelect+    internal_to_base_ioManager Internal.IoManagerFlagMIO         = IoManagerFlagMIO+    internal_to_base_ioManager Internal.IoManagerFlagWinIO       = IoManagerFlagWinIO+    internal_to_base_ioManager Internal.IoManagerFlagWin32Legacy = IoManagerFlagWin32Legacy++internal_to_base_DebugFlags :: Internal.DebugFlags -> DebugFlags+internal_to_base_DebugFlags Internal.DebugFlags{..} = DebugFlags{..}++internal_to_base_CCFlags :: Internal.CCFlags -> CCFlags+internal_to_base_CCFlags i@Internal.CCFlags{..} =+  let do_cost_centres = internal_to_base_costCentres (Internal.doCostCentres i)+  in CCFlags{ doCostCentres = do_cost_centres, ..}+  where+    internal_to_base_costCentres :: Internal.DoCostCentres -> DoCostCentres+    internal_to_base_costCentres Internal.CostCentresNone    = CostCentresNone+    internal_to_base_costCentres Internal.CostCentresSummary = CostCentresSummary+    internal_to_base_costCentres Internal.CostCentresVerbose = CostCentresVerbose+    internal_to_base_costCentres Internal.CostCentresAll     = CostCentresAll+    internal_to_base_costCentres Internal.CostCentresJSON    = CostCentresJSON++internal_to_base_ProfFlags :: Internal.ProfFlags -> ProfFlags+internal_to_base_ProfFlags i@Internal.ProfFlags{..} =+  let do_heap_profile = internal_to_base_doHeapProfile (Internal.doHeapProfile i)+  in ProfFlags{ doHeapProfile = do_heap_profile,..}+  where+    internal_to_base_doHeapProfile :: Internal.DoHeapProfile -> DoHeapProfile+    internal_to_base_doHeapProfile Internal.NoHeapProfiling   = NoHeapProfiling+    internal_to_base_doHeapProfile Internal.HeapByCCS         = HeapByCCS+    internal_to_base_doHeapProfile Internal.HeapByMod         = HeapByMod+    internal_to_base_doHeapProfile Internal.HeapByDescr       = HeapByDescr+    internal_to_base_doHeapProfile Internal.HeapByType        = HeapByType+    internal_to_base_doHeapProfile Internal.HeapByRetainer    = HeapByRetainer+    internal_to_base_doHeapProfile Internal.HeapByLDV         = HeapByLDV+    internal_to_base_doHeapProfile Internal.HeapByClosureType = HeapByClosureType+    internal_to_base_doHeapProfile Internal.HeapByInfoTable   = HeapByInfoTable+    internal_to_base_doHeapProfile Internal.HeapByEra         = HeapByEra++internal_to_base_TraceFlags :: Internal.TraceFlags -> TraceFlags+internal_to_base_TraceFlags i@Internal.TraceFlags{..} =+  let do_trace = internal_to_base_doTrace (Internal.tracing i)+  in TraceFlags{ tracing = do_trace,..}+  where+    internal_to_base_doTrace :: Internal.DoTrace -> DoTrace+    internal_to_base_doTrace Internal.TraceNone     = TraceNone+    internal_to_base_doTrace Internal.TraceEventLog = TraceEventLog+    internal_to_base_doTrace Internal.TraceStderr   = TraceStderr++internal_to_base_TickyFlags :: Internal.TickyFlags -> TickyFlags+internal_to_base_TickyFlags Internal.TickyFlags{..} = TickyFlags{..}++-------------------------------- shims -----------------------------------------++getRTSFlags :: IO RTSFlags+getRTSFlags = internal_to_base_RTSFlags <$> Internal.getRTSFlags++getGCFlags :: IO GCFlags+getGCFlags = internal_to_base_GCFlags <$> Internal.getGCFlags++getParFlags :: IO ParFlags+getParFlags = internal_to_base_ParFlags <$> Internal.getParFlags++getHpcFlags :: IO HpcFlags+getHpcFlags = internal_to_base_HpcFlags <$> Internal.getHpcFlags++getConcFlags :: IO ConcFlags+getConcFlags =  internal_to_base_ConcFlags <$> Internal.getConcFlags++{-# INLINEABLE getMiscFlags #-}+getMiscFlags :: IO MiscFlags+getMiscFlags = internal_to_base_MiscFlags <$> Internal.getMiscFlags++getDebugFlags :: IO DebugFlags+getDebugFlags = internal_to_base_DebugFlags <$> Internal.getDebugFlags++getCCFlags :: IO CCFlags+getCCFlags = internal_to_base_CCFlags <$> Internal.getCCFlags++getProfFlags :: IO ProfFlags+getProfFlags = internal_to_base_ProfFlags <$> Internal.getProfFlags++getTraceFlags :: IO TraceFlags+getTraceFlags = internal_to_base_TraceFlags <$> Internal.getTraceFlags++getTickyFlags :: IO TickyFlags+getTickyFlags = internal_to_base_TickyFlags <$> Internal.getTickyFlags
+ src/GHC/Read.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Read+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Read' class and instances for basic data types.+--++module GHC.Read+  ( -- * Class+    Read(..)++  -- * ReadS type+  , ReadS++  -- * Haskell 2010 compatibility+  , lex+  , lexLitChar+  , readLitChar+  , lexDigits++  -- * Defining readers+  , lexP, expectP+  , paren+  , parens+  , list+  , choose+  , readListDefault, readListPrecDefault+  , readNumber+  , readField+  , readFieldHash+  , readSymField++  , readParen+  )+ where++import GHC.Internal.Read
+ src/GHC/Real.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Real+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The types 'Ratio' and 'Rational', and the classes 'Real', 'Fractional',+-- 'Integral', and 'RealFrac'.+--++module GHC.Real+    ( -- * Classes+      Real(..)+    , Integral(..)+    , Fractional(..)+    , RealFrac(..)++      -- * Conversion+    , fromIntegral+    , realToFrac++      -- * Formatting+    , showSigned++      -- * Predicates+    , even+    , odd++      -- * Arithmetic+    , (^)+    , (^^)+    , gcd+    , lcm++      -- * 'Ratio'+    , Ratio(..)+    , Rational+    , infinity+    , notANumber++      -- * 'Enum' helpers+    , numericEnumFrom+    , numericEnumFromThen+    , numericEnumFromTo+    , numericEnumFromThenTo+    , integralEnumFrom+    , integralEnumFromThen+    , integralEnumFromTo+    , integralEnumFromThenTo++      -- ** Construction+    , (%)++      -- ** Projection+    , numerator+    , denominator++      -- ** Operations+    , reduce++      -- * Internal+    , ratioPrec+    , ratioPrec1+    , divZeroError+    , ratioZeroDenominatorError+    , overflowError+    , underflowError+    , mkRationalBase2+    , mkRationalBase10+    , FractionalExponentBase(..)+    , (^%^)+    , (^^%^^)+    , mkRationalWithExponentBase+    , powImpl+    , powImplAcc+    ) where++import GHC.Internal.Real
+ src/GHC/Records.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.Records+-- Copyright   :  (c) Adam Gundry 2015-2016+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- This module defines the 'HasField' class used by the+-- @OverloadedRecordDot@ extension.  See the+-- [wiki page](https://gitlab.haskell.org/ghc/ghc/wikis/records/overloaded-record-fields)+-- for more details.+--+-- @since 4.10.0.0++module GHC.Records+    (HasField(..)+     ) where++import GHC.Internal.Records
+ src/GHC/ResponseFile.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.ResponseFile+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  portable+--+-- GCC style response files.+--+-- @since 4.12.0.0++module GHC.ResponseFile (+    getArgsWithResponseFiles,+    unescapeArgs,+    escapeArgs,+    expandResponse+  ) where++import GHC.Internal.ResponseFile
+ src/GHC/ST.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.ST+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'ST' Monad.+--++module GHC.ST+    (ST(..),+     STret(..),+     STRep,+     runST,+     -- *  Unsafe functions+     liftST,+     unsafeInterleaveST,+     unsafeDupableInterleaveST+     ) where++import GHC.Internal.ST
+ src/GHC/STRef.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.STRef+-- Copyright   :  (c) The University of Glasgow, 1994-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- References in the 'ST' monad.+--++module GHC.STRef+    (STRef(..),+     newSTRef,+     readSTRef,+     writeSTRef+     ) where++import GHC.Internal.STRef
+ src/GHC/Show.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Show+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- The 'Show' class, and related operations.+--++module GHC.Show+        (+        Show(..), ShowS,++        -- * Show support code+        shows, showChar, showString, showMultiLineString,+        showParen, showList__, showCommaSpace, showSpace,+        showLitChar, showLitString, protectEsc,+        intToDigit, showSignedInt,+        appPrec, appPrec1,++        -- * Character operations+        asciiTab,+  ) where++import GHC.Internal.Show
+ src/GHC/Stable.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  GHC.Stable+-- Copyright   :  (c) The University of Glasgow, 1992-2004+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Stable pointers.+--++module GHC.Stable (+        StablePtr(..),+        newStablePtr,+        deRefStablePtr,+        freeStablePtr,+        castStablePtrToPtr,+        castPtrToStablePtr+    ) where++import GHC.Internal.Stable
+ src/GHC/StableName.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  System.Mem.StableName+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- Stable names are a way of performing fast ( \(\mathcal{O}(1)\) ),+-- not-quite-exact comparison between objects.+--+-- Stable names solve the following problem: suppose you want to build+-- a hash table with Haskell objects as keys, but you want to use+-- pointer equality for comparison; maybe because the keys are large+-- and hashing would be slow, or perhaps because the keys are infinite+-- in size.  We can\'t build a hash table using the address of the+-- object as the key, because objects get moved around by the garbage+-- collector, meaning a re-hash would be necessary after every garbage+-- collection.+--++module GHC.StableName+    (-- *  Stable Names+     StableName(..),+     makeStableName,+     hashStableName,+     eqStableName+     ) where++import GHC.Internal.StableName
+ src/GHC/Stack.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  GHC.Stack+-- Copyright   :  (c) The University of Glasgow 2011+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Access to GHC's call-stack simulation+--+-- @since 4.5.0.0++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.Internal.Stack
+ src/GHC/Stack/CCS.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.Stack.CCS+-- Copyright   :  (c) The University of Glasgow 2011+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Access to GHC's call-stack simulation+--+-- @since 4.5.0.0++module GHC.Stack.CCS (+    -- * Call stacks+    currentCallStack,+    whoCreated,++    -- * Internals+    CostCentreStack,+    CostCentre,+    getCurrentCCS,+    getCCSOf,+    clearCCS,+    ccsCC,+    ccsParent,+    ccLabel,+    ccModule,+    ccSrcSpan,+    ccsToStrings,+    renderStack,+  ) where++import GHC.Internal.Stack.CCS
+ src/GHC/Stack/CloneStack.hs view
@@ -0,0 +1,20 @@+-- |+-- This module exposes an interface for capturing the state of a thread's+-- execution stack for diagnostics purposes: 'cloneMyStack',+-- 'cloneThreadStack'.+--+-- Such a "cloned" stack can be decoded with 'decode' to a stack trace, given+-- that the @-finfo-table-map@ is enabled.+--+-- @since 4.17.0.0++module GHC.Stack.CloneStack (+  StackSnapshot(..),+  StackEntry(..),+  cloneMyStack,+  cloneThreadStack,+  decode+  ) where++import GHC.Internal.Stack.CloneStack+import GHC.Internal.Stack.Decode
+ src/GHC/Stack/Types.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Stack.Types+-- Copyright   :  (c) The University of Glasgow 2015+-- License     :  see libraries/ghc-prim/LICENSE+--+-- Maintainer  :  ghc-devs@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.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.Stack.Types+    (-- *  Implicit call stacks+     CallStack(..),+     HasCallStack,+     emptyCallStack,+     freezeCallStack,+     fromCallSiteList,+     getCallStack,+     pushCallStack,+     -- *  Source locations+     SrcLoc(..)+     ) where++import GHC.Internal.Stack.Types
+ src/GHC/StaticPtr.hs view
@@ -0,0 +1,44 @@+-- |+-- Module      :  GHC.StaticPtr+-- Copyright   :  (C) 2014 I/O Tweag+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Symbolic references to values.+--+-- References to values are usually implemented with memory addresses, and this+-- is practical when communicating values between the different pieces of a+-- single process.+--+-- When values are communicated across different processes running in possibly+-- different machines, though, addresses are no longer useful since each+-- process may use different addresses to store a given value.+--+-- To solve such concern, the references provided by this module offer a key+-- that can be used to locate the values on each process. Each process maintains+-- a global table of references which can be looked up with a given key. This+-- table is known as the Static Pointer Table. The reference can then be+-- dereferenced to obtain the value.+--+-- The various communicating processes need to agree on the keys used to refer+-- to the values in the Static Pointer Table, or lookups will fail. Only+-- processes launched from the same program binary are guaranteed to use the+-- same set of keys.+--++module GHC.StaticPtr+  ( StaticPtr+  , deRefStaticPtr+  , StaticKey+  , staticKey+  , unsafeLookupStaticPtr+  , StaticPtrInfo(..)+  , staticPtrInfo+  , staticPtrKeys+  , IsStatic(..)+  ) where++import GHC.Internal.StaticPtr
+ src/GHC/Stats.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Safe            #-}++-- |+-- Module      :  RTS.Stats+-- Copyright   :  (c) The University of Glasgow, 1994-2000+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- This module provides access to internal garbage collection and+-- memory usage statistics.  These statistics are not available unless+-- a program is run with the @-T@ RTS flag.+--+-- /The API of this module is unstable and is tightly coupled to GHC's internals./+-- If depend on it, make sure to use a tight upper bound, e.g., @base < 4.X@ rather+-- than @base < 5@, because the interface can change rapidly without much warning.+--+-- @since 4.5.0.0+--+-- This module is a compatibility layer. It is meant to be temporary to allow+-- for the eventual deprecation of these declarations as described in [CLC+-- proposal+-- #289](https://github.com/haskell/core-libraries-committee/issues/289). These+-- declarations are now instead available from the @ghc-experimental@ package.++module GHC.Stats+    ( -- * Runtime statistics+      RTSStats(..), GCDetails(..), RtsTime+    , getRTSStats+    , getRTSStatsEnabled+    ) where+++import Prelude (Bool,IO,Read,Show,(<$>))++import qualified GHC.Internal.Stats as Internal+import GHC.Generics (Generic)+import Data.Word (Word64,Word32)+import Data.Int (Int64)++-- | Time values from the RTS, using a fixed resolution of nanoseconds.+type RtsTime = Int64++--+-- | Statistics about runtime activity since the start of the+-- program.  This is a mirror of the C @struct RTSStats@ in @RtsAPI.h@+--+-- @since base-4.10.0.0+--+data RTSStats = RTSStats {+  -- -----------------------------------+  -- Cumulative stats about memory use++    -- | Total number of GCs+    gcs :: Word32+    -- | Total number of major (oldest generation) GCs+  , major_gcs :: Word32+    -- | Total bytes allocated+  , allocated_bytes :: Word64+    -- | Maximum live data (including large objects + compact regions) in the+    -- heap. Updated after a major GC.+  , max_live_bytes :: Word64+    -- | Maximum live data in large objects+  , max_large_objects_bytes :: Word64+    -- | Maximum live data in compact regions+  , max_compact_bytes :: Word64+    -- | Maximum slop+  , max_slop_bytes :: Word64+    -- | Maximum memory in use by the RTS+  , max_mem_in_use_bytes :: Word64+    -- | Sum of live bytes across all major GCs.  Divided by major_gcs+    -- gives the average live data over the lifetime of the program.+  , cumulative_live_bytes :: Word64+    -- | Sum of copied_bytes across all GCs+  , copied_bytes :: Word64+    -- | Sum of copied_bytes across all parallel GCs+  , par_copied_bytes :: Word64+    -- | Sum of par_max_copied_bytes across all parallel GCs. Deprecated.+  , cumulative_par_max_copied_bytes :: Word64+    -- | Sum of par_balanced_copied bytes across all parallel GCs+  , cumulative_par_balanced_copied_bytes :: Word64++  -- -----------------------------------+  -- Cumulative stats about time use+  -- (we use signed values here because due to inaccuracies in timers+  -- the values can occasionally go slightly negative)++    -- | Total CPU time used by the init phase+    -- @since base-4.12.0.0+  , init_cpu_ns :: RtsTime+    -- | Total elapsed time used by the init phase+    -- @since base-4.12.0.0+  , init_elapsed_ns :: RtsTime+    -- | Total CPU time used by the mutator+  , mutator_cpu_ns :: RtsTime+    -- | Total elapsed time used by the mutator+  , mutator_elapsed_ns :: RtsTime+    -- | Total CPU time used by the GC+  , gc_cpu_ns :: RtsTime+    -- | Total elapsed time used by the GC+  , gc_elapsed_ns :: RtsTime+    -- | Total CPU time (at the previous GC)+  , cpu_ns :: RtsTime+    -- | Total elapsed time (at the previous GC)+  , elapsed_ns :: RtsTime++    -- | The total CPU time used during the post-mark pause phase of the+    -- concurrent nonmoving GC.+  , nonmoving_gc_sync_cpu_ns :: RtsTime+    -- | The total time elapsed during the post-mark pause phase of the+    -- concurrent nonmoving GC.+  , nonmoving_gc_sync_elapsed_ns :: RtsTime+    -- | The maximum elapsed length of any post-mark pause phase of the+    -- concurrent nonmoving GC.+  , nonmoving_gc_sync_max_elapsed_ns :: RtsTime+    -- | The total CPU time used by the nonmoving GC.+  , nonmoving_gc_cpu_ns :: RtsTime+    -- | The total time elapsed during which there is a nonmoving GC active.+  , nonmoving_gc_elapsed_ns :: RtsTime+    -- | The maximum time elapsed during any nonmoving GC cycle.+  , nonmoving_gc_max_elapsed_ns :: RtsTime++    -- | Details about the most recent GC+  , gc :: GCDetails+  } deriving ( Read -- ^ @since base-4.10.0.0+             , Show -- ^ @since base-4.10.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++--+-- | Statistics about a single GC.  This is a mirror of the C @struct+--   GCDetails@ in @RtsAPI.h@, with the field prefixed with @gc_@ to+--   avoid collisions with 'RTSStats'.+--+data GCDetails = GCDetails {+    -- | The generation number of this GC+    gcdetails_gen :: Word32+    -- | Number of threads used in this GC+  , gcdetails_threads :: Word32+    -- | Number of bytes allocated since the previous GC+  , gcdetails_allocated_bytes :: Word64+    -- | Total amount of live data in the heap (includes large + compact data).+    -- Updated after every GC. Data in uncollected generations (in minor GCs)+    -- are considered live.+  , gcdetails_live_bytes :: Word64+    -- | Total amount of live data in large objects+  , gcdetails_large_objects_bytes :: Word64+    -- | Total amount of live data in compact regions+  , gcdetails_compact_bytes :: Word64+    -- | Total amount of slop (wasted memory)+  , gcdetails_slop_bytes :: Word64+    -- | Total amount of memory in use by the RTS+  , gcdetails_mem_in_use_bytes :: Word64+    -- | Total amount of data copied during this GC+  , gcdetails_copied_bytes :: Word64+    -- | In parallel GC, the max amount of data copied by any one thread.+    -- Deprecated.+  , gcdetails_par_max_copied_bytes :: Word64+    -- | In parallel GC, the amount of balanced data copied by all threads+  , gcdetails_par_balanced_copied_bytes :: Word64+    -- | The amount of memory lost due to block fragmentation in bytes.+    -- Block fragmentation is the difference between the amount of blocks retained by the RTS and the blocks that are in use.+    -- This occurs when megablocks are only sparsely used, eg, when data that cannot be moved retains a megablock.+    --+    -- @since base-4.18.0.0+  , gcdetails_block_fragmentation_bytes :: Word64+    -- | The time elapsed during synchronisation before GC+  , gcdetails_sync_elapsed_ns :: RtsTime+    -- | The CPU time used during GC itself+  , gcdetails_cpu_ns :: RtsTime+    -- | The time elapsed during GC itself+  , gcdetails_elapsed_ns :: RtsTime++    -- | The CPU time used during the post-mark pause phase of the concurrent+    -- nonmoving GC.+  , gcdetails_nonmoving_gc_sync_cpu_ns :: RtsTime+    -- | The time elapsed during the post-mark pause phase of the concurrent+    -- nonmoving GC.+  , gcdetails_nonmoving_gc_sync_elapsed_ns :: RtsTime+  } deriving ( Read -- ^ @since base-4.10.0.0+             , Show -- ^ @since base-4.10.0.0+             , Generic -- ^ @since base-4.15.0.0+             )++-------------------------------- compat ----------------------------------------++internal_to_base_RTSStats :: Internal.RTSStats -> RTSStats+internal_to_base_RTSStats i@Internal.RTSStats{..} =+  let gc_details = internal_to_base_GCDetails (Internal.gc i)+  in RTSStats{gc = gc_details,..}++internal_to_base_GCDetails :: Internal.GCDetails -> GCDetails+internal_to_base_GCDetails Internal.GCDetails{..} = GCDetails{..}++-------------------------------- shims -----------------------------------------++getRTSStats :: IO RTSStats+getRTSStats = internal_to_base_RTSStats <$> Internal.getRTSStats++getRTSStatsEnabled :: IO Bool+getRTSStatsEnabled = Internal.getRTSStatsEnabled
+ src/GHC/Storable.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Storable+-- Copyright   :  (c) The FFI task force, 2000-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ffi@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Helper functions for "Foreign.Storable"+--++module GHC.Storable+    (readWideCharOffPtr,+     readIntOffPtr,+     readWordOffPtr,+     readPtrOffPtr,+     readFunPtrOffPtr,+     readFloatOffPtr,+     readDoubleOffPtr,+     readStablePtrOffPtr,+     readInt8OffPtr,+     readInt16OffPtr,+     readInt32OffPtr,+     readInt64OffPtr,+     readWord8OffPtr,+     readWord16OffPtr,+     readWord32OffPtr,+     readWord64OffPtr,+     writeWideCharOffPtr,+     writeIntOffPtr,+     writeWordOffPtr,+     writePtrOffPtr,+     writeFunPtrOffPtr,+     writeFloatOffPtr,+     writeDoubleOffPtr,+     writeStablePtrOffPtr,+     writeInt8OffPtr,+     writeInt16OffPtr,+     writeInt32OffPtr,+     writeInt64OffPtr,+     writeWord8OffPtr,+     writeWord16OffPtr,+     writeWord32OffPtr,+     writeWord64OffPtr+     ) where++import GHC.Internal.Storable
+ src/GHC/TopHandler.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.TopHandler+-- Copyright   :  (c) The University of Glasgow, 2001-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Support for catching exceptions raised during top-level computations+-- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--++module GHC.TopHandler+    (runMainIO,+     runIO,+     runIOFastExit,+     runNonIO,+     topHandler,+     topHandlerFastExit,+     reportStackOverflow,+     reportError,+     flushStdHandles+     ) where++import GHC.Internal.TopHandler
+ src/GHC/TypeError.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++{-|+This module exports:++  - The 'TypeError' type family, which is used to provide custom type+    errors. This is a type-level analogue to the term level error function.+  - The 'ErrorMessage' kind, used to define custom error messages.+  - The 'Unsatisfiable' constraint, a more principled variant of 'TypeError'+    which gives a more predictable way of reporting custom type errors.++@since 4.17.0.0+-}++module GHC.TypeError+  ( ErrorMessage (..)+  , TypeError+  , Assert+  , Unsatisfiable, unsatisfiable+  ) where++import GHC.Internal.TypeError
+ src/GHC/TypeLits.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++-- |+--+-- GHC's @DataKinds@ language extension lifts data constructors, natural+-- numbers, and strings to the type level. This module provides the+-- primitives needed for working with type-level numbers (the 'Nat' kind),+-- strings (the 'Symbol' kind), and characters (the 'Char' kind). It also defines the 'TypeError' type+-- family, a feature that makes use of type-level strings to support user+-- defined type errors.+--+-- For now, this module is the API for working with type-level literals.+-- However, please note that it is a work in progress and is subject to change.+-- Once the design of the @DataKinds@ feature is more stable, this will be+-- considered only an internal GHC module, and the programmer interface for+-- working with type-level data will be defined in a separate library.+--+-- @since 4.6.0.0+--++module GHC.TypeLits+    (-- *  Kinds+     Natural,+     Nat,+     Symbol,+     -- *  Linking type and value level+     KnownNat(natSing),+     natVal,+     natVal',+     KnownSymbol(symbolSing),+     symbolVal,+     symbolVal',+     KnownChar(charSing),+     charVal,+     charVal',+     SomeNat(..),+     SomeSymbol(..),+     SomeChar(..),+     someNatVal,+     someSymbolVal,+     someCharVal,+     sameNat,+     sameSymbol,+     sameChar,+     decideNat,+     decideSymbol,+     decideChar,+     OrderingI(..),+     cmpNat,+     cmpSymbol,+     cmpChar,+     -- **  Singleton values+     SNat,+     SSymbol,+     SChar,+     pattern SNat,+     pattern SSymbol,+     pattern SChar,+     fromSNat,+     fromSSymbol,+     fromSChar,+     withSomeSNat,+     withSomeSSymbol,+     withSomeSChar,+     withKnownNat,+     withKnownSymbol,+     withKnownChar,+     -- *  Functions on type literals+     type (<=),+     type (<=?),+     type (+),+     type (*),+     type (^),+     type (-),+     type Div,+     type Mod,+     type Log2,+     AppendSymbol,+     CmpNat,+     CmpSymbol,+     CmpChar,+     ConsSymbol,+     UnconsSymbol,+     CharToNat,+     NatToChar,+     -- *  User-defined type errors+     TypeError,+     ErrorMessage(..)+     ) where++import GHC.Internal.TypeLits
+ src/GHC/TypeNats.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++-- |+-- This module is an internal GHC module.  It declares the constants used+-- in the implementation of type-level natural numbers.  The programmer interface+-- for working with type-level naturals should be defined in a separate module.+--+-- @since 4.10.0.0+--++module GHC.TypeNats+    (-- *  Nat Kind+     Natural,+     Nat,+     -- *  Linking type and value level+     KnownNat(natSing),+     natVal,+     natVal',+     SomeNat(..),+     someNatVal,+     sameNat,+     decideNat,+     -- **  Singleton values+     SNat,+     pattern SNat,+     fromSNat,+     withSomeSNat,+     withKnownNat,+     -- *  Functions on type literals+     type (<=),+     type (<=?),+     type (+),+     type (*),+     type (^),+     type (-),+     CmpNat,+     cmpNat,+     Div,+     Mod,+     Log2+     ) where++import GHC.Internal.TypeNats
+ src/GHC/Unicode.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Unicode+-- Copyright   :  (c) The University of Glasgow, 2003+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC extensions)+--+-- Implementations for the character predicates (isLower, isUpper, etc.)+-- and the conversions (toUpper, toLower).  The implementation uses+-- libunicode on Unix systems if that is available.+--++module GHC.Unicode+    (unicodeVersion,+     GeneralCategory(..),+     generalCategory,+     isAscii,+     isLatin1,+     isControl,+     isAsciiUpper,+     isAsciiLower,+     isPrint,+     isSpace,+     isUpper,+     isUpperCase,+     isLower,+     isLowerCase,+     isAlpha,+     isDigit,+     isOctDigit,+     isHexDigit,+     isAlphaNum,+     isPunctuation,+     isSymbol,+     toUpper,+     toLower,+     toTitle+     ) where++import GHC.Internal.Unicode
+ src/GHC/Weak.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Weak+-- Copyright   :  (c) The University of Glasgow, 1998-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Weak pointers.+--++module GHC.Weak+    (Weak(..),+     mkWeak,+     deRefWeak,+     finalize,+     -- *  Handling exceptions+     -- |  When an exception is thrown by a finalizer called by the+     -- garbage collector, GHC calls a global handler which can be set with+     -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by+     -- this handler will be ignored.+     setFinalizerExceptionHandler,+     getFinalizerExceptionHandler,+     printToHandleFinalizerExceptionHandler+     ) where++import GHC.Internal.Weak
+ src/GHC/Weak/Finalize.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE MagicHash #-}+module GHC.Weak.Finalize+    ( -- * Handling exceptions+      -- | When an exception is thrown by a finalizer called by the+      -- garbage collector, GHC calls a global handler which can be set with+      -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by+      -- this handler will be ignored.+      setFinalizerExceptionHandler+    , getFinalizerExceptionHandler+    , printToHandleFinalizerExceptionHandler+      -- * Internal+    , GHC.Weak.Finalize.runFinalizerBatch+    ) where++import GHC.Internal.Weak.Finalize++-- These imports can be removed once runFinalizerBatch is removed,+-- as can MagicHash above.+import GHC.Internal.Base (Int, Array#, IO, State#, RealWorld)+++{-# DEPRECATED runFinalizerBatch+    "This function is internal to GHC. It will not be exported in future." #-}+-- | Run a batch of finalizers from the garbage collector. Given an+-- array of finalizers and the length of the array, just call each one+-- in turn.+--+-- This is an internal detail of the GHC RTS weak pointer finaliser+-- mechanism. It should no longer be exported from base. There is no+-- good reason to use it. It will be removed in the next major version+-- of base (4.23.*).+--+-- See <https://github.com/haskell/core-libraries-committee/issues/342>+--+runFinalizerBatch :: Int+                  -> Array# (State# RealWorld -> State# RealWorld)+                  -> IO ()+runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch
+ src/GHC/Windows.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}++-- |+-- Module      :  GHC.Windows+-- Copyright   :  (c) The University of Glasgow, 2009+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- Windows functionality used by several modules.+--+-- ToDo: this just duplicates part of System.Win32.Types, which isn't+-- available yet.  We should move some Win32 functionality down here,+-- maybe as part of the grand reorganisation of the base package...+--++module GHC.Windows+#if defined(javascript_HOST_ARCH)+    ( ) where++#else+    (+        -- * Types+        BOOL,+        LPBOOL,+        BYTE,+        DWORD,+        DDWORD,+        UINT,+        ULONG,+        ErrCode,+        HANDLE,+        LPWSTR,+        LPTSTR,+        LPCTSTR,+        LPVOID,+        LPDWORD,+        LPSTR,+        LPCSTR,+        LPCWSTR,+        WORD,+        UCHAR,+        NTSTATUS,++        -- * Constants+        iNFINITE,+        iNVALID_HANDLE_VALUE,++        -- * System errors+        throwGetLastError,+        failWith,+        getLastError,+        getErrorMessage,+        errCodeToIOError,++        -- ** Guards for system calls that might fail+        failIf,+        failIf_,+        failIfNull,+        failIfZero,+        failIfFalse_,+        failUnlessSuccess,+        failUnlessSuccessOr,++        -- ** Mapping system errors to errno+        -- $errno+        c_maperrno,+        c_maperrno_func,++        -- * Misc+        ddwordToDwords,+        dwordsToDdword,+        nullHANDLE,+    ) where++#endif++import GHC.Internal.Windows+
+ src/GHC/Word.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- Module      :  GHC.Word+-- Copyright   :  (c) The University of Glasgow, 1997-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+-- Sized unsigned integral types: 'Word', 'Word8', 'Word16', 'Word32', and+-- 'Word64'.+--++module GHC.Word+    (Word(..),+     Word8(..),+     Word16(..),+     Word32(..),+     Word64(..),+     -- *  Shifts+     uncheckedShiftL64#,+     uncheckedShiftRL64#,+     -- *  Byte swapping+     byteSwap16,+     byteSwap32,+     byteSwap64,+     -- *  Bit reversal+     bitReverse8,+     bitReverse16,+     bitReverse32,+     bitReverse64,+     -- *  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 GHC.Internal.Word
+ src/Numeric.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Numeric+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Odds and ends, mostly functions for reading and showing+-- 'RealFloat'-like kind of values.+--++module Numeric+    (-- *  Showing+     showSigned,+     showIntAtBase,+     showInt,+     showBin,+     showHex,+     showOct,+     showEFloat,+     showFFloat,+     showGFloat,+     showFFloatAlt,+     showGFloatAlt,+     showFloat,+     showHFloat,+     floatToDigits,+     -- *  Reading+     -- |  /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase',+     -- and 'readDec' is the \`dual\' of 'showInt'.+     -- The inconsistent naming is a historical accident.+     readSigned,+     readInt,+     readBin,+     readDec,+     readOct,+     readHex,+     readFloat,+     lexDigits,+     -- *  Miscellaneous+     fromRat,+     Floating(..)+     ) where++import GHC.Internal.Numeric
+ src/Numeric/Natural.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Numeric.Natural+-- Copyright   :  (C) 2014 Herbert Valerio Riedel,+--                (C) 2011 Edward Kmett+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The arbitrary-precision 'Natural' number type.+--+-- @since 4.8.0.0++module Numeric.Natural+    (Natural,+     minusNaturalMaybe+     ) where++import GHC.Internal.Numeric.Natural
+ src/Prelude.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ExplicitNamespaces #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Prelude+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The Prelude: a standard module. The Prelude is imported by default+-- into all Haskell modules unless either there is an explicit import+-- statement for it, or the NoImplicitPrelude extension is enabled.+--+-----------------------------------------------------------------------------++module Prelude (++    -- * Standard types, classes and related functions++    -- ** Basic data types+    Bool(False, True),+    (&&), (||), not, otherwise,++    Maybe(Nothing, Just),+    maybe,++    Either(Left, Right),+    either,++    Ordering(LT, EQ, GT),+    Char, String,++    -- *** Tuples+    fst, snd, curry, uncurry,++    -- ** Basic type classes+    Eq((==), (/=)),+    Ord(compare, (<), (<=), (>=), (>), max, min),+    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,+         enumFromTo, enumFromThenTo),+    Bounded(minBound, maxBound),++    -- ** Numbers++    -- *** Numeric types+    Int, Integer, Float, Double,+    Rational, Word,++    -- *** Numeric type classes+    Num((+), (-), (*), negate, abs, signum, fromInteger),+    Real(toRational),+    Integral(quot, rem, div, mod, quotRem, divMod, toInteger),+    Fractional((/), recip, fromRational),+    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,+             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),+    RealFrac(properFraction, truncate, round, ceiling, floor),+    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,+              encodeFloat, exponent, significand, scaleFloat, isNaN,+              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),++    -- *** Numeric functions+    subtract, even, odd, gcd, lcm, (^), (^^),+    fromIntegral, realToFrac,++    -- ** Semigroups and Monoids+    Semigroup((<>)),+    Monoid(mempty, mappend, mconcat),++    -- ** Monads and functors+    Functor(fmap, (<$)), (<$>),+    Applicative(pure, (<*>), (*>), (<*), liftA2),+    Monad((>>=), (>>), return),+    MonadFail(fail),+    mapM_, sequence_, (=<<),++    -- ** Folds and traversals+    Foldable(elem,      -- :: (Foldable t, Eq a) => a -> t a -> Bool+             -- fold,   -- :: Monoid m => t m -> m+             foldMap,   -- :: Monoid m => (a -> m) -> t a -> m+             foldr,     -- :: (a -> b -> b) -> b -> t a -> b+             -- foldr', -- :: (a -> b -> b) -> b -> t a -> b+             foldl,     -- :: (b -> a -> b) -> b -> t a -> b+             foldl', -- :: (b -> a -> b) -> b -> t a -> b+             foldr1,    -- :: (a -> a -> a) -> t a -> a+             foldl1,    -- :: (a -> a -> a) -> t a -> a+             maximum,   -- :: (Foldable t, Ord a) => t a -> a+             minimum,   -- :: (Foldable t, Ord a) => t a -> a+             product,   -- :: (Foldable t, Num a) => t a -> a+             sum),      -- :: Num a => t a -> a+             -- toList) -- :: Foldable t => t a -> [a]++    Traversable(traverse, sequenceA, mapM, sequence),++    -- ** Miscellaneous functions+    id, const, (.), flip, ($), until,+    asTypeOf, error, errorWithoutStackTrace, undefined,+    seq, ($!),++    -- * List operations+    List.map, (List.++), List.filter,+    List.head, List.last, List.tail, List.init, (List.!!),+    Foldable.null, Foldable.length,+    List.reverse,+    -- *** Special folds+    Foldable.and, Foldable.or, Foldable.any, Foldable.all,+    Foldable.concat, Foldable.concatMap,+    -- ** Building lists+    -- *** Scans+    List.scanl, List.scanl1, List.scanr, List.scanr1,+    -- *** Infinite lists+    List.iterate, List.repeat, List.replicate, List.cycle,+    -- ** Sublists+    List.take, List.drop,+    List.takeWhile, List.dropWhile,+    List.span, List.break,+    List.splitAt,+    -- ** Searching lists+    Foldable.notElem,+    List.lookup,+    -- ** Zipping and unzipping lists+    List.zip, List.zip3,+    List.zipWith, List.zipWith3,+    List.unzip, List.unzip3,+    -- ** Functions on strings+    List.lines, List.words, List.unlines, List.unwords,++    -- * Converting to and from @String@+    -- ** Converting to @String@+    ShowS,+    Show(showsPrec, showList, show),+    shows,+    showChar, showString, showParen,+    -- ** Converting from @String@+    ReadS,+    Read(readsPrec, readList),+    reads, readParen, read, lex,++    -- * Basic Input and output+    IO,+    -- ** Simple I\/O operations+    -- All I/O functions defined here are character oriented.  The+    -- treatment of the newline character will vary on different systems.+    -- For example, two characters of input, return and linefeed, may+    -- read as a single newline character.  These functions cannot be+    -- used portably for binary I/O.+    -- *** Output functions+    putChar,+    putStr, putStrLn, print,+    -- *** Input functions+    getChar,+    getLine, getContents, interact,+    -- *** Files+    FilePath,+    readFile, writeFile, appendFile, readIO, readLn,+    -- ** Exception handling in the I\/O monad+    IOError, ioError, userError,++    -- ** The equality types+    type (~)+  ) where++import GHC.Internal.Control.Monad+import GHC.Internal.System.IO+import GHC.Internal.System.IO.Error+import qualified GHC.Internal.Data.List as List+import GHC.Internal.Data.Either+import GHC.Internal.Data.Foldable    ( Foldable(..) )+import qualified GHC.Internal.Data.Foldable as Foldable+import GHC.Internal.Data.Functor     ( (<$>) )+import GHC.Internal.Data.Maybe+import GHC.Internal.Data.Traversable ( Traversable(..) )+import GHC.Internal.Data.Tuple++import GHC.Internal.Base hiding ( foldr, mapM, sequence )+import GHC.Internal.Text.Read+import GHC.Internal.Enum+import GHC.Internal.Num+import GHC.Internal.Real+import GHC.Internal.Float+import GHC.Internal.Show
+ src/System/CPUTime.hsc view
@@ -0,0 +1,71 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP, CApiFFI #-}++-----------------------------------------------------------------------------+-- |+-- 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+--+-- The standard CPUTime library.+--+-----------------------------------------------------------------------------++#include "HsFFI.h"+#include "HsBaseConfig.h"++-- For various _POSIX_* #defines+#if defined(HAVE_UNISTD_H)+#include <unistd.h>+#endif++module System.CPUTime+    ( getCPUTime+    , cpuTimePrecision+    ) where++import Prelude+import System.IO.Unsafe (unsafePerformIO)++-- Here is where we decide which backend to use+#if defined(mingw32_HOST_OS)+import qualified System.CPUTime.Windows as I++#elif defined(javascript_HOST_ARCH)+import qualified System.CPUTime.Javascript as I++#elif _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0+import qualified System.CPUTime.Posix.ClockGetTime as I++#elif defined(HAVE_GETRUSAGE) && ! solaris2_HOST_OS+import qualified System.CPUTime.Posix.RUsage as I++-- @getrusage()@ is right royal pain to deal with when targeting 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+-- again in libucb in 2.6..)+--+-- Avoid the problem by resorting to times() instead.+#elif defined(HAVE_TIMES)+import qualified System.CPUTime.Posix.Times as I++#else+import qualified System.CPUTime.Unsupported as I+#endif++-- | The 'cpuTimePrecision' constant is the smallest measurable difference+-- in CPU time that the implementation can record, and is given as an+-- integral number of picoseconds.+cpuTimePrecision :: Integer+cpuTimePrecision = unsafePerformIO I.getCpuTimePrecision+{-# NOINLINE cpuTimePrecision #-}++-- | Computation 'getCPUTime' returns the number of picoseconds CPU time+-- used by the current program.  The precision of this result is+-- implementation-dependent.+getCPUTime :: IO Integer+getCPUTime = I.getCPUTime
+ src/System/CPUTime/Javascript.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE JavaScriptFFI #-}++module System.CPUTime.Javascript+  ( getCPUTime+  , getCpuTimePrecision+  )+where++import qualified System.CPUTime.Unsupported as I+import Prelude++getCpuTimePrecision :: IO Integer+getCpuTimePrecision = toInteger <$> js_cpuTimePrecision++getCPUTime :: IO Integer+getCPUTime = do+  t <- js_getCPUTime+  if t == -1 then I.getCPUTime+             else pure (1000 * round t)++foreign import javascript unsafe+  "(() => { return h$cpuTimePrecision(); })"+  js_cpuTimePrecision :: IO Int++foreign import javascript unsafe+  "(() => { return h$getCPUTime(); })"+  js_getCPUTime :: IO Double
+ src/System/CPUTime/Posix/ClockGetTime.hsc view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}++#include "HsFFI.h"+#include "HsBaseConfig.h"+#include <unistd.h>+#include <time.h>++module System.CPUTime.Posix.ClockGetTime+    ( getCPUTime+    , getCpuTimePrecision+    ) where++import Prelude++#if _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0++import Foreign+import Foreign.C+import System.CPUTime.Utils++getCPUTime :: IO Integer+getCPUTime = fmap snd $ withTimespec $ \ts ->+    throwErrnoIfMinus1_ "clock_gettime"+    $ clock_gettime cLOCK_PROCESS_CPUTIME_ID ts++getCpuTimePrecision :: IO Integer+getCpuTimePrecision = fmap snd $ withTimespec $ \ts ->+    throwErrnoIfMinus1_ "clock_getres"+    $ clock_getres cLOCK_PROCESS_CPUTIME_ID ts++data Timespec++-- | Perform the given action to fill in a @struct timespec@, returning the+-- result of the action and the value of the @timespec@ in picoseconds.+withTimespec :: (Ptr Timespec -> IO a) -> IO (a, Integer)+withTimespec action =+    allocaBytes (# const sizeof(struct timespec)) $ \p_ts -> do+        r <- action p_ts+        u_sec  <- (#peek struct timespec,tv_sec)  p_ts :: IO CTime+        u_nsec <- (#peek struct timespec,tv_nsec) p_ts :: IO CLong+        return (r, cTimeToInteger u_sec * 1e12 + fromIntegral u_nsec * 1e3)++foreign import capi unsafe "time.h clock_getres"  clock_getres  :: CUIntPtr -> Ptr Timespec -> IO CInt+foreign import capi unsafe "time.h clock_gettime" clock_gettime :: CUIntPtr -> Ptr Timespec -> IO CInt++#if HAVE_DECL_CLOCK_PROCESS_CPUTIME_ID+foreign import capi unsafe "time.h value CLOCK_PROCESS_CPUTIME_ID" cLOCK_PROCESS_CPUTIME_ID :: CUIntPtr+#else+foreign import capi unsafe "time.h value CLOCK_MONOTONIC" cLOCK_PROCESS_CPUTIME_ID :: CUIntPtr+#endif // HAVE_DECL_CLOCK_PROCESS_CPUTIME_ID++#else++-- This should never happen+getCPUTime :: IO Integer+getCPUTime = error "System.CPUTime.Posix.ClockGetTime: Unsupported"++getCpuTimePrecision :: IO Integer+getCpuTimePrecision = error "System.CPUTime.Posix.ClockGetTime: Unsupported"++#endif // _POSIX_CPUTIME
+ src/System/CPUTime/Posix/RUsage.hsc view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}++#include "HsFFI.h"+#include "HsBaseConfig.h"++module System.CPUTime.Posix.RUsage+    ( getCPUTime+    , getCpuTimePrecision+    ) where++import Prelude+import Data.Ratio+import Foreign+import Foreign.C+import System.CPUTime.Utils++-- For struct rusage+#if HAVE_SYS_RESOURCE_H+#include <sys/resource.h>+#endif++#if HAVE_GETRUSAGE++getCPUTime :: IO Integer+getCPUTime = allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do+    throwErrnoIfMinus1_ "getrusage" $ getrusage (#const RUSAGE_SELF) p_rusage++    let ru_utime = (#ptr struct rusage, ru_utime) p_rusage+    let ru_stime = (#ptr struct rusage, ru_stime) p_rusage+    u_sec  <- (#peek struct timeval,tv_sec)  ru_utime :: IO CTime+    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+    let usec = cTimeToInteger u_sec * 1e6 + csuSecondsToInteger u_usec ++               cTimeToInteger s_sec * 1e6 + csuSecondsToInteger s_usec+    return (usec * 1e6)++type CRUsage = ()+foreign import capi unsafe "HsBase.h getrusage" getrusage :: CInt -> Ptr CRUsage -> IO CInt++getCpuTimePrecision :: IO Integer+getCpuTimePrecision =+    return $ round ((1e12::Integer) % fromIntegral clk_tck)++foreign import ccall unsafe clk_tck :: CLong++#else++getCPUTime :: IO Integer+getCPUTime = fail "System.CPUTime.Posix.RUsage.getCPUTime"++getCpuTimePrecision :: IO Integer+getCpuTimePrecision = fail "System.CPUTime.Posix.RUsage.getCpuTimePrecision"++#endif
+ src/System/CPUTime/Posix/Times.hsc view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}++#include "HsFFI.h"+#include "HsBaseConfig.h"++module System.CPUTime.Posix.Times+    ( getCPUTime+    , getCpuTimePrecision+    ) where++import Prelude+import Foreign+import Data.Ratio+import GHC.Internal.Foreign.C.Types+import System.CPUTime.Utils++-- for struct tms+#if HAVE_SYS_TIMES_H+#include <sys/times.h>+#endif++#if HAVE_TIMES++getCPUTime :: IO Integer+getCPUTime = allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do+    _ <- 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 (( (cClockToInteger u_ticks + cClockToInteger s_ticks) * 1e12)+                        `div` fromIntegral clockTicks)++type CTms = ()+foreign import ccall unsafe times :: Ptr CTms -> IO CClock++getCpuTimePrecision :: IO Integer+getCpuTimePrecision =+    return $ round ((1e12::Integer) % clockTicks)++foreign import ccall unsafe clk_tck :: CLong++clockTicks :: Integer+clockTicks = fromIntegral clk_tck++#else++getCPUTime :: IO Integer+getCPUTime = fail "System.CPUTime.Posix.Times.getCPUTime"++getCpuTimePrecision :: IO Integer+getCpuTimePrecision = fail "System.CPUTime.Posix.Times.getCpuTimePrecision"++#endif
+ src/System/CPUTime/Unsupported.hs view
@@ -0,0 +1,21 @@+module System.CPUTime.Unsupported+    ( getCPUTime+    , getCpuTimePrecision+    ) where++import GHC.Internal.IO.Exception+import Prelude++getCPUTime :: IO Integer+getCPUTime =+    ioError (IOError Nothing UnsupportedOperation+                     "getCPUTime"+                     "can't get CPU time"+                     Nothing Nothing)++getCpuTimePrecision :: IO Integer+getCpuTimePrecision =+    ioError (IOError Nothing UnsupportedOperation+                     "cpuTimePrecision"+                     "can't get CPU time"+                     Nothing Nothing)
+ src/System/CPUTime/Utils.hs view
@@ -0,0 +1,21 @@+module System.CPUTime.Utils+    ( -- * Integer conversions+      -- | These types have no 'Integral' instances in the Haskell report+      -- so we must do this ourselves.+      cClockToInteger+    , cTimeToInteger+    , csuSecondsToInteger+    ) where++import GHC.Internal.Foreign.C.Types+import GHC.Num.Integer (Integer)+import GHC.Internal.Real (fromIntegral)++cClockToInteger :: CClock -> Integer+cClockToInteger (CClock n) = fromIntegral n++cTimeToInteger :: CTime -> Integer+cTimeToInteger (CTime n) = fromIntegral n++csuSecondsToInteger :: CSUSeconds -> Integer+csuSecondsToInteger (CSUSeconds n) = fromIntegral n
+ src/System/CPUTime/Windows.hsc view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP, CApiFFI, NondecreasingIndentation, NumDecimals #-}++#include "HsFFI.h"+#include "HsBaseConfig.h"++module System.CPUTime.Windows+    ( getCPUTime+    , getCpuTimePrecision+    ) where++import GHC.Internal.Foreign.Ptr+import GHC.Internal.Foreign.Marshal.Alloc+import GHC.Internal.Foreign.Marshal.Utils+import GHC.Internal.Foreign.Storable+import GHC.Internal.Foreign.C.Types+import GHC.Internal.Word+import Prelude++-- For FILETIME etc. on Windows+#if HAVE_WINDOWS_H+#include <windows.h>+#endif++getCPUTime :: IO Integer+getCPUTime = do+     -- NOTE: GetProcessTimes() is only supported on NT-based OSes.+     -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units.+    allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do+    allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do+    allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do+    allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do+    pid <- getCurrentProcess+    ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime+    if toBool ok then do+      ut <- ft2psecs p_userTime+      kt <- ft2psecs p_kernelTime+      return (ut + kt)+     else return 0+  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)+            -- => multiply by 10^5.+          return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000)++    -- ToDo: pin down elapsed times to just the OS thread(s) that+    -- are evaluating/managing Haskell code.++-- While it's hard to get reliable numbers, the consensus is that Windows only provides+-- 16 millisecond resolution in GetProcessTimes (see Python PEP 0418)+getCpuTimePrecision :: IO Integer+getCpuTimePrecision = return 16e9++type FILETIME = ()+type HANDLE = ()++-- need proper Haskell names (initial lower-case character)+#if defined(i386_HOST_ARCH)+foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)+foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt+#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+foreign import ccall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)+foreign import ccall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt+#else+#error Unknown mingw32 arch+#endif
+ src/System/Console/GetOpt.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Console.GetOpt+-- Copyright   :  (c) Sven Panne 2002-2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- This module provides facilities for parsing the command-line options+-- in a standalone program.  It is essentially a Haskell port of the GNU+-- @getopt@ library.+--+-----------------------------------------------------------------------------++{-+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+  are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+  compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example!+:-)+-}++module System.Console.GetOpt (+   -- * GetOpt+   getOpt, getOpt',+   usageInfo,+   ArgOrder(..),+   OptDescr(..),+   ArgDescr(..),++   -- * Examples++   -- |To hopefully illuminate the role of the different data structures,+   -- here are the command-line options for a (very simple) compiler,+   -- done in two different ways.+   -- The difference arises because the type of 'getOpt' is+   -- parameterized by the type of values derived from flags.++   -- ** Interpreting flags as concrete values+   -- $example1++   -- ** Interpreting flags as transformations of an options record+   -- $example2+) where++import Prelude+import GHC.Internal.Data.List ( isPrefixOf, find )++-- |What to do with options following non-options+data ArgOrder a+  = RequireOrder                -- ^ no option processing after first non-option+  | Permute                     -- ^ freely intersperse options and non-options+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options++{-|+Each 'OptDescr' describes a single option.++The arguments to 'Option' are:++* list of short option characters++* list of long option strings (without \"--\")++* argument descriptor++* explanation of option for user+-}+data OptDescr a =              -- description of a single options:+   Option [Char]                --    list of short option characters+          [String]              --    list of long option strings (without "--")+          (ArgDescr a)          --    argument descriptor+          String                --    explanation of option for user++-- |Describes whether an option takes an argument or not, and if so+-- how the argument is injected into a value of type @a@.+data ArgDescr a+   = NoArg                   a         -- ^   no argument expected+   | ReqArg (String       -> a) String -- ^   option requires argument+   | OptArg (Maybe String -> a) String -- ^   optional argument++-- | @since 4.7.0.0+instance Functor ArgOrder where+    fmap _ RequireOrder      = RequireOrder+    fmap _ Permute           = Permute+    fmap f (ReturnInOrder g) = ReturnInOrder (f . g)++-- | @since 4.7.0.0+instance Functor OptDescr where+    fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c++-- | @since 4.7.0.0+instance Functor ArgDescr where+    fmap f (NoArg a)    = NoArg (f a)+    fmap f (ReqArg g s) = ReqArg (f . g) s+    fmap f (OptArg g s) = OptArg (f . g) s++data OptKind a                -- kind of cmd line arg (internal use only):+   = Opt       a                --    an option+   | UnreqOpt  String           --    an un-recognized option+   | NonOpt    String           --    a non-option+   | EndOfOpts                  --    end-of-options marker (i.e. "--")+   | OptErr    String           --    something went wrong...++-- | Return a string describing the usage of a command, derived from+-- the header (first argument) and the options described by the+-- second argument.+usageInfo :: String                    -- header+          -> [OptDescr a]              -- option descriptors+          -> String                    -- nicely formatted description of options+usageInfo header optDescr = unlines (header:table)+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> [(String,String,String)]+fmtOpt (Option sos los ad descr) =+   case lines descr of+     []     -> [(sosFmt,losFmt,"")]+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]+   where sepBy _  []     = ""+         sepBy _  [x]    = x+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs+         sosFmt = sepBy ',' (map (fmtShort ad) sos)+         losFmt = sepBy ',' (map (fmtLong  ad) los)++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++{-|+Process the command-line, and return the list of values that matched+(and those that didn\'t). The arguments are:++* The order requirements (see 'ArgOrder')++* The option descriptions (see 'OptDescr')++* The actual command line arguments (presumably got from+  'GHC.Internal.System.Environment.getArgs').++'getOpt' returns a triple consisting of the option arguments, a list+of non-options, and a list of error messages.+-}+getOpt :: ArgOrder a                   -- non-option handling+       -> [OptDescr a]                 -- option descriptors+       -> [String]                     -- the command-line arguments+       -> ([a],[String],[String])      -- (options,non-options,error messages)+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)+   where (os,xs,us,es) = getOpt' ordering optDescr args++{-|+This is almost the same as 'getOpt', but returns a quadruple+consisting of the option arguments, a list of non-options, a list of+unrecognized options, and a list of error messages.+-}+getOpt' :: ArgOrder a                         -- non-option handling+        -> [OptDescr a]                       -- option descriptors+        -> [String]                           -- the command-line arguments+        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)+getOpt' _        _        []         =  ([],[],[],[])+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering+   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)+         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)+         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])+         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)+         procNextOpt (NonOpt x)   (ReturnInOrder f) = (f x :os, xs,us,es)+         procNextOpt EndOfOpts    RequireOrder      = ([],rest,[],[])+         procNextOpt EndOfOpts    Permute           = ([],rest,[],[])+         procNextOpt EndOfOpts    (ReturnInOrder f) = (map f rest,[],[],[])+         procNextOpt (OptErr e)   _                 = (os,xs,us,e:es)++         (opt,rest) = getNext arg args optDescr+         (os,xs,us,es) = getOpt' ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a            rest _        = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+   where (opt,arg) = break (=='=') ls+         getWith p = [ o | o@(Option _ xs _ _) <- optDescr+                         , find (p opt) xs /= Nothing ]+         exact     = getWith (==)+         options   = if null exact then getWith isPrefixOf else exact+         ads       = [ ad | Option _ _ ad _ <- options ]+         optStr    = ("--"++opt)++         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)+         long [NoArg  a  ] []       rest     = (Opt a,rest)+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)+         long [ReqArg _ d] []       []       = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)+         long _            _        rest     = (UnreqOpt ("--"++ls),rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt y ys rs optDescr = short ads ys rs+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]+        ads     = [ ad | Option _ _ ad _ <- options ]+        optStr  = '-':[y]++        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)+        short (NoArg  a  :_) [] rest     = (Opt a,rest)+        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)+        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)+        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)+        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)+        short []             [] rest     = (UnreqOpt optStr,rest)+        short []             xs rest     = (UnreqOpt optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> String+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show++options :: [OptDescr Flag]+options =+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing  = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"+                        (_,_,errs) -> concat errs ++ usageInfo header options+   where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+--    ==> options=[Verbose]  args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+--    ==> options=[Arg "foo", Verbose]  args=[]+-- putStr (test Permute ["foo","--","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]+-- putStr (test Permute ["--ver","foo"])+--    ==> option `--ver' is ambiguous; could be one of:+--          -v      --verbose             verbosely list files+--          -V, -?  --version, --release  show version info+--        Usage: foobar [OPTION...] files...+--          -v        --verbose             verbosely list files+--          -V, -?    --version, --release  show version info+--          -o[FILE]  --output[=FILE]       use FILE for dump+--          -n USER   --name=USER           only dump USER's files+-----------------------------------------------------------------------------------------+-}++{- $example1++A simple choice for the type associated with flags is to define a type+@Flag@ as an algebraic type representing the possible flags and their+arguments:++>    module Opts1 where+>+>    import System.Console.GetOpt+>    import GHC.Internal.Data.Maybe ( fromMaybe )+>+>    data Flag+>     = Verbose  | Version+>     | Input String | Output String | LibDir String+>       deriving Show+>+>    options :: [OptDescr Flag]+>    options =+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"+>     ]+>+>    inp,outp :: Maybe String -> Flag+>    outp = Output . fromMaybe "stdout"+>    inp  = Input  . fromMaybe "stdin"+>+>    compilerOpts :: [String] -> IO ([Flag], [String])+>    compilerOpts argv =+>       case getOpt Permute options argv of+>          (o,n,[]  ) -> return (o,n)+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+>      where header = "Usage: ic [OPTION...] files..."++Then the rest of the program will use the constructed list of flags+to determine it\'s behaviour.++-}++{- $example2++A different approach is to group the option values in a record of type+@Options@, and have each flag yield a function of type+@Options -> Options@ transforming this record.++>    module Opts2 where+>+>    import System.Console.GetOpt+>    import GHC.Internal.Data.Maybe ( fromMaybe )+>+>    data Options = Options+>     { optVerbose     :: Bool+>     , optShowVersion :: Bool+>     , optOutput      :: Maybe FilePath+>     , optInput       :: Maybe FilePath+>     , optLibDirs     :: [FilePath]+>     } deriving Show+>+>    defaultOptions    = Options+>     { optVerbose     = False+>     , optShowVersion = False+>     , optOutput      = Nothing+>     , optInput       = Nothing+>     , optLibDirs     = []+>     }+>+>    options :: [OptDescr (Options -> Options)]+>    options =+>     [ Option ['v']     ["verbose"]+>         (NoArg (\ opts -> opts { optVerbose = True }))+>         "chatty output on stderr"+>     , Option ['V','?'] ["version"]+>         (NoArg (\ opts -> opts { optShowVersion = True }))+>         "show version number"+>     , Option ['o']     ["output"]+>         (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")+>                 "FILE")+>         "output FILE"+>     , Option ['c']     []+>         (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")+>                 "FILE")+>         "input FILE"+>     , Option ['L']     ["libdir"]+>         (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")+>         "library directory"+>     ]+>+>    compilerOpts :: [String] -> IO (Options, [String])+>    compilerOpts argv =+>       case getOpt Permute options argv of+>          (o,n,[]  ) -> return (foldl (flip id) defaultOptions o, n)+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+>      where header = "Usage: ic [OPTION...] files..."++Similarly, each flag could yield a monadic function transforming a record,+of type @Options -> IO Options@ (or any other monad), allowing option+processing to perform actions of the chosen monad, e.g. printing help or+version messages, checking that file arguments exist, etc.++-}+
+ src/System/Environment.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  System.Environment+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Miscellaneous information about the system environment.+--++module System.Environment+    (+      getArgs,+      getProgName,+      executablePath,+      getExecutablePath,+      getEnv,+      lookupEnv,+      setEnv,+      unsetEnv,+      withArgs,+      withProgName,+      getEnvironment,+  ) where++import GHC.Internal.System.Environment
+ src/System/Environment/Blank.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE Safe #-}++-- |+-- Module      :  System.Environment.Blank+-- Copyright   :  (c) Habib Alamin 2017+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A setEnv implementation that allows blank environment variables. Mimics+-- the `System.Posix.Env` module from the @unix@ package, but with support+-- for Windows too.+--+-- The matrix of platforms that:+--+--   * support @putenv("FOO")@ to unset environment variables,+--   * support @putenv("FOO=")@ to unset environment variables or set them+--     to blank values,+--   * support @unsetenv@ to unset environment variables,+--   * support @setenv@ to set environment variables,+--   * etc.+--+-- is very complicated. Some platforms don't support unsetting of environment+-- variables at all.+--++module System.Environment.Blank+    (+      module System.Environment,+      getEnv,+      getEnvDefault,+      setEnv,+      unsetEnv,+  ) where++import System.Environment+    (+      getArgs,+      getProgName,+      getExecutablePath,+      withArgs,+      withProgName,+      getEnvironment+    )++import GHC.Internal.System.Environment.Blank
+ src/System/Exit.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  System.Exit+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Exiting the program.+--++module System.Exit+    (ExitCode(ExitSuccess, ExitFailure),+     exitWith,+     exitFailure,+     exitSuccess,+     die+     ) where++import GHC.Internal.System.Exit
+ src/System/IO.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  System.IO+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- The standard IO API.+--++module System.IO+    (-- * Examples+     -- $stdio_examples++     -- *  The IO monad+     IO,+     fixIO,+     -- *  Files and handles+     FilePath,+     Handle,+     -- |  GHC note: a 'Handle' will be automatically closed when the garbage+     -- collector detects that it has become unreferenced by the program.+     -- However, relying on this behaviour is not generally recommended:+     -- the garbage collector is unpredictable.  If possible, use+     -- an explicit 'hClose' to close 'Handle's when they are no longer+     -- required.  GHC does not currently attempt to free up file+     -- descriptors when they have run out, it is your responsibility to+     -- ensure that this doesn't happen.++     -- **  Standard handles+     -- |  Three handles are allocated during program initialisation,+     -- and are initially open.+     stdin,+     stdout,+     stderr,+     -- *  Opening and closing files+     -- **  Opening files+     withFile,+     openFile,+     IOMode(ReadMode, WriteMode, AppendMode, ReadWriteMode),+     -- **  Closing files+     hClose,+     -- **  Special cases+     -- |  These functions are also exported by the "Prelude".+     readFile,+     readFile',+     writeFile,+     appendFile,+     -- **  File locking+     -- $locking+     -- *  Operations on handles+     -- **  Determining and changing the size of a file+     hFileSize,+     hSetFileSize,+     -- **  Detecting the end of input+     hIsEOF,+     isEOF,+     -- **  Buffering operations+     BufferMode(NoBuffering, LineBuffering, BlockBuffering),+     hSetBuffering,+     hGetBuffering,+     hFlush,+     -- **  Repositioning handles+     hGetPosn,+     hSetPosn,+     HandlePosn,+     hSeek,+     SeekMode(AbsoluteSeek, RelativeSeek, SeekFromEnd),+     hTell,+     -- **  Handle properties+     hIsOpen,+     hIsClosed,+     hIsReadable,+     hIsWritable,+     hIsSeekable,+     -- **  Terminal operations (not portable: GHC only)+     hIsTerminalDevice,+     hSetEcho,+     hGetEcho,+     -- **  Showing handle state (not portable: GHC only)+     hShow,+     -- *  Text input and output+     -- **  Text input+     hWaitForInput,+     hReady,+     hGetChar,+     hGetLine,+     hLookAhead,+     hGetContents,+     hGetContents',+     -- **  Text output+     hPutChar,+     hPutStr,+     hPutStrLn,+     hPrint,+     -- **  Special cases for standard input and output+     -- |  These functions are also exported by the "Prelude".+     interact,+     putChar,+     putStr,+     putStrLn,+     print,+     getChar,+     getLine,+     getContents,+     getContents',+     readIO,+     readLn,+     -- *  Binary input and output+     withBinaryFile,+     openBinaryFile,+     hSetBinaryMode,+     hPutBuf,+     hGetBuf,+     hGetBufSome,+     hPutBufNonBlocking,+     hGetBufNonBlocking,+     -- *  Temporary files+     openTempFile,+     openBinaryTempFile,+     openTempFileWithDefaultPermissions,+     openBinaryTempFileWithDefaultPermissions,+     -- *  Unicode encoding\/decoding+     -- |  A text-mode 'Handle' has an associated 'TextEncoding', which+     -- is used to decode bytes into Unicode characters when reading,+     -- and encode Unicode characters into bytes when writing.+     --+     -- The default 'TextEncoding' is the same as the default encoding+     -- on your system, which is also available as 'localeEncoding'.+     -- (GHC note: on Windows, we currently do not support double-byte+     -- encodings; if the console\'s code page is unsupported, then+     -- 'localeEncoding' will be 'latin1'.)+     --+     -- Encoding and decoding errors are always detected and reported,+     -- except during lazy I/O ('hGetContents', 'getContents', and+     -- 'readFile'), where a decoding error merely results in+     -- termination of the character stream, as with other I/O errors.+     hSetEncoding,+     hGetEncoding,+     -- **  Unicode encodings+     TextEncoding,+     latin1,+     utf8,+     utf8_bom,+     utf16,+     utf16le,+     utf16be,+     utf32,+     utf32le,+     utf32be,+     localeEncoding,+     char8,+     mkTextEncoding,+     -- *  Newline conversion+     -- | In Haskell, a newline is always represented by the character+     -- @\'\\n\'@.  However, in files and external character streams, a+     -- newline may be represented by another character sequence, such+     -- as @\'\\r\\n\'@.+     --+     -- A text-mode 'Handle' has an associated 'NewlineMode' that+     -- specifies how to translate newline characters.  The+     -- 'NewlineMode' specifies the input and output translation+     -- separately, so that for instance you can translate @\'\\r\\n\'@+     -- to @\'\\n\'@ on input, but leave newlines as @\'\\n\'@ on output.+     --+     -- The default 'NewlineMode' for a 'Handle' is+     -- 'nativeNewlineMode', which does no translation on Unix systems,+     -- but translates @\'\\r\\n\'@ to @\'\\n\'@ and back on Windows.+     --+     -- Binary-mode 'Handle's do no newline translation at all.++     hSetNewlineMode,+     Newline(..),+     nativeNewline,+     NewlineMode(..),+     noNewlineTranslation,+     universalNewlineMode,+     nativeNewlineMode+     ) where++import GHC.Internal.System.IO++-- $locking+-- Implementations should enforce as far as possible, at least locally to the+-- Haskell process, multiple-reader single-writer locking on files.+-- That is, /there may either be many handles on the same file which manage input, or just one handle on the file which manages output/.  If any+-- open or semi-closed handle is managing a file for output, no new+-- handle can be allocated for that file.  If any open or semi-closed+-- handle is managing a file for input, new handles can only be allocated+-- if they do not manage output.  Whether two files are the same is+-- implementation-dependent, but they should normally be the same if they+-- have the same absolute path name and neither has been renamed, for+-- example.+--+-- /Warning/: the 'readFile' operation holds a semi-closed handle on+-- the file until the entire contents of the file have been consumed.+-- It follows that an attempt to write to a file (using 'writeFile', for+-- example) that was earlier opened by 'readFile' will usually result in+-- failure with 'GHC.Internal.System.IO.Error.isAlreadyInUseError'.++-- $stdio_examples+-- Note: Some of the examples in this module do not work "as is" in ghci.+-- This is because using 'stdin' in combination with lazy IO+-- does not work well in interactive mode.+--+-- Lines starting with @>@ indicate 'stdin' and @^D@ signales EOF.+--+-- ==== __Example__+--+-- ghci> foo+-- > input+-- output+-- > input^D+-- output
+ src/System/IO/Error.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  System.IO.Error+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Standard IO Errors.+--++module System.IO.Error+    (-- *  I\/O errors+     IOError,+     userError,+     mkIOError,+     annotateIOError,+     -- **  Classifying I\/O errors+     isAlreadyExistsError,+     isDoesNotExistError,+     isAlreadyInUseError,+     isFullError,+     isEOFError,+     isIllegalOperation,+     isPermissionError,+     isUserError,+     isResourceVanishedError,+     -- **  Attributes of I\/O errors+     ioeGetErrorType,+     ioeGetLocation,+     ioeGetErrorString,+     ioeGetHandle,+     ioeGetFileName,+     ioeSetErrorType,+     ioeSetErrorString,+     ioeSetLocation,+     ioeSetHandle,+     ioeSetFileName,+     -- *  Types of I\/O error+     IOErrorType,+     alreadyExistsErrorType,+     doesNotExistErrorType,+     alreadyInUseErrorType,+     fullErrorType,+     eofErrorType,+     illegalOperationErrorType,+     permissionErrorType,+     userErrorType,+     resourceVanishedErrorType,+     -- **  'IOErrorType' predicates+     isAlreadyExistsErrorType,+     isDoesNotExistErrorType,+     isAlreadyInUseErrorType,+     isFullErrorType,+     isEOFErrorType,+     isIllegalOperationErrorType,+     isPermissionErrorType,+     isUserErrorType,+     isResourceVanishedErrorType,+     -- *  Throwing and catching I\/O errors+     ioError,+     catchIOError,+     tryIOError,+     modifyIOError+     ) where++import GHC.Internal.System.IO.Error
+ src/System/IO/Unsafe.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE NoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.IO.Unsafe+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- \"Unsafe\" IO operations.+--+-----------------------------------------------------------------------------++module System.IO.Unsafe (+   -- * Unsafe 'System.IO.IO' operations+   unsafePerformIO,+   unsafeDupablePerformIO,+   unsafeInterleaveIO,+   unsafeFixIO,+  ) where++import GHC.Internal.Base+import GHC.Internal.IO+import GHC.Internal.IORef+import GHC.Internal.Exception+import GHC.Internal.Control.Exception++-- | A slightly faster version of `GHC.Internal.System.IO.fixIO` that may not be+-- safe to use with multiple threads.  The unsafety arises when used+-- like this:+--+-- >  unsafeFixIO $ \r -> do+-- >     forkIO (print r)+-- >     return (...)+--+-- In this case, the child thread will receive a @NonTermination@+-- exception instead of waiting for the value of @r@ to be computed.+--+-- @since 4.5.0.0+unsafeFixIO :: (a -> IO a) -> IO a+unsafeFixIO k = do+  ref <- newIORef (throw NonTermination)+  ans <- unsafeDupableInterleaveIO (readIORef ref)+  result <- k ans+  writeIORef ref result+  return result
+ src/System/Info.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP  #-}+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Info+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  portable+--+-- Information about the characteristics of the host+-- system lucky enough to run your program.+--+-- For a comprehensive listing of supported platforms, please refer to+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/platforms+-----------------------------------------------------------------------------++module System.Info+  ( os+  , arch+  , compilerName+  , compilerVersion+  , fullCompilerVersion+  ) where++import GHC.Internal.Data.Version (Version (..))+import Prelude++-- | The version of 'compilerName' with which the program was compiled+-- or is being interpreted.+--+-- ==== __Example__+-- > ghci> compilerVersion+-- > Version {versionBranch = [8,8], versionTags = []}+compilerVersion :: Version+compilerVersion = Version [major, minor] []+  where (major, minor) = compilerVersionRaw `divMod` 100++-- | The full version of 'compilerName' with which the program was compiled+-- or is being interpreted. It includes the major, minor, revision and an additional+-- identifier, generally in the form "<year><month><day>".+fullCompilerVersion :: Version+fullCompilerVersion = Version version []+  where+    version :: [Int]+    version = fmap read $ splitVersion __GLASGOW_HASKELL_FULL_VERSION__++splitVersion :: String -> [String]+splitVersion s =+  case dropWhile (== '.') s of+    "" -> []+    s' -> let (w, s'') = break (== '.') s'+           in w : splitVersion s''++#include "ghcplatform.h"++-- | The operating system on which the program is running.+-- Common values include:+--+--     * "darwin" — macOS+--     * "freebsd"+--     * "linux"+--     * "linux-android"+--     * "mingw32" — Windows+--     * "netbsd"+--     * "openbsd"+os :: String+os = HOST_OS++-- | The machine architecture on which the program is running.+-- Common values include:+--+--    * "aarch64"+--    * "alpha"+--    * "arm"+--    * "hppa"+--    * "hppa1_1"+--    * "i386"+--    * "ia64"+--    * "m68k"+--    * "mips"+--    * "mipseb"+--    * "mipsel"+--    * "nios2"+--    * "powerpc"+--    * "powerpc64"+--    * "powerpc64le"+--    * "riscv32"+--    * "riscv64"+--    * "loongarch32"+--    * "loongarch64"+--    * "rs6000"+--    * "s390"+--    * "s390x"+--    * "sh4"+--    * "sparc"+--    * "sparc64"+--    * "vax"+--    * "x86_64"+arch :: String+arch = HOST_ARCH++-- | The Haskell implementation with which the program was compiled+-- or is being interpreted.+-- On the GHC platform, the value is "ghc".+compilerName :: String+compilerName = "ghc"++compilerVersionRaw :: Int+compilerVersionRaw = __GLASGOW_HASKELL__
+ src/System/Mem.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  System.Mem+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Memory-related system things.+--++module System.Mem+    (-- *  Garbage collection+     performGC,+     performMajorGC,+     performBlockingMajorGC,+     performMinorGC,+     -- *  Allocation counter and limits+     setAllocationCounter,+     getAllocationCounter,+     enableAllocationLimit,+     disableAllocationLimit+     ) where++import GHC.Internal.System.Mem
+ src/System/Mem/StableName.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  System.Mem.StableName+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- Stable names are a way of performing fast ( \(\mathcal{O}(1)\) ),+-- not-quite-exact comparison between objects.+--+-- Stable names solve the following problem: suppose you want to build+-- a hash table with Haskell objects as keys, but you want to use+-- pointer equality for comparison; maybe because the keys are large+-- and hashing would be slow, or perhaps because the keys are infinite+-- in size.  We can\'t build a hash table using the address of the+-- object as the key, because objects get moved around by the garbage+-- collector, meaning a re-hash would be necessary after every garbage+-- collection.+--+-- See [Stretching the storage manager: weak pointers and stable names in+-- Haskell](https://www.microsoft.com/en-us/research/publication/stretching-the-storage-manager-weak-pointers-and-stable-names-in-haskell/)+-- by Simon Peyton Jones, Simon Marlow and Conal Elliott for detailed discussion+-- of stable names. An implementation of a memo table with stable names+-- can be found in [@stable-memo@](https://hackage.haskell.org/package/stable-memo)+-- package.+--++module System.Mem.StableName+    (-- *  Stable Names+     StableName,+     makeStableName,+     hashStableName,+     eqStableName+     ) where++import GHC.Internal.System.Mem.StableName
+ src/System/Mem/Weak.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Mem.Weak+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- In general terms, a weak pointer is a reference to an object that is+-- not followed by the garbage collector - that is, the existence of a+-- weak pointer to an object has no effect on the lifetime of that+-- object.  A weak pointer can be de-referenced to find out+-- whether the object it refers to is still alive or not, and if so+-- to return the object itself.+--+-- Weak pointers are particularly useful for caches and memo tables.+-- To build a memo table, you build a data structure+-- mapping from the function argument (the key) to its result (the+-- value).  When you apply the function to a new argument you first+-- check whether the key\/value pair is already in the memo table.+-- The key point is that the memo table itself should not keep the+-- key and value alive.  So the table should contain a weak pointer+-- to the key, not an ordinary pointer.  The pointer to the value must+-- not be weak, because the only reference to the value might indeed be+-- from the memo table.+--+-- So it looks as if the memo table will keep all its values+-- alive for ever.  One way to solve this is to purge the table+-- occasionally, by deleting entries whose keys have died.+--+-- The weak pointers in this module+-- support another approach, called /finalization/.+-- When the key referred to by a weak pointer dies, the storage manager+-- arranges to run a programmer-specified finalizer.  In the case of memo+-- tables, for example, the finalizer could remove the key\/value pair+-- from the memo table.+--+-- Another difficulty with the memo table is that the value of a+-- key\/value pair might itself contain a pointer to the key.+-- So the memo table keeps the value alive, which keeps the key alive,+-- even though there may be no other references to the key so both should+-- die.  The weak pointers in this module provide a slight+-- generalisation of the basic weak-pointer idea, in which each+-- weak pointer actually contains both a key and a value.+--+-- See [Stretching the storage manager: weak pointers and stable names in+-- Haskell](https://www.microsoft.com/en-us/research/publication/stretching-the-storage-manager-weak-pointers-and-stable-names-in-haskell/)+-- by Simon Peyton Jones, Simon Marlow and Conal Elliott for detailed discussion+-- of weak pointers. An implementation of a memo table with weak pointers+-- can be found in [@stable-memo@](https://hackage.haskell.org/package/stable-memo)+-- package.+--+-----------------------------------------------------------------------------++module System.Mem.Weak (+        -- * The @Weak@ type+        Weak,                   -- abstract++        -- * The general interface+        mkWeak,+        deRefWeak,+        finalize,++        -- * Specialised versions+        mkWeakPtr,+        addFinalizer,+        mkWeakPair,+        -- replaceFinaliser++        -- * Handling exceptions+        -- | When an exception is thrown by a finalizer called by the+        -- garbage collector, GHC calls a global handler which can be set with+        -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by+        -- this handler will be ignored.+        setFinalizerExceptionHandler,+        getFinalizerExceptionHandler,+        printToHandleFinalizerExceptionHandler,++        -- * A precise semantics++        -- $precise++        -- * Implementation notes++        -- $notes+   ) where++import Prelude+import GHC.Internal.Weak++-- | A specialised version of 'mkWeak', where the key and the value are+-- the same object:+--+-- > mkWeakPtr key finalizer = mkWeak key key finalizer+--+mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k)+mkWeakPtr key finalizer = mkWeak key key finalizer++{-|+  A specialised version of 'mkWeakPtr', where the 'Weak' object+  returned is simply thrown away (however the finalizer will be+  remembered by the garbage collector, and will still be run+  when the key becomes unreachable).++  Note: adding a finalizer to a 'Foreign.ForeignPtr.ForeignPtr' using+  'addFinalizer' won't work; use the specialised version+  'GHC.Internal.Foreign.ForeignPtr.addForeignPtrFinalizer' instead.  For discussion+  see the 'Weak' type.+.+-}+addFinalizer :: key -> IO () -> IO ()+addFinalizer key finalizer = do+   _ <- mkWeakPtr key (Just finalizer) -- throw it away+   return ()++-- | A specialised version of 'mkWeak' where the value is actually a pair+-- of the key and value passed to 'mkWeakPair':+--+-- > mkWeakPair key val finalizer = mkWeak key (key,val) finalizer+--+-- The advantage of this is that the key can be retrieved by 'deRefWeak'+-- in addition to the value.+mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))+mkWeakPair key val finalizer = mkWeak key (key,val) finalizer+++{- $precise++The above informal specification is fine for simple situations, but+matters can get complicated.  In particular, it needs to be clear+exactly when a key dies, so that any weak pointers that refer to it+can be finalized.  Suppose, for example, the value of one weak pointer+refers to the key of another...does that keep the key alive?++The behaviour is simply this:++ *  If a weak pointer (object) refers to an /unreachable/+    key, it may be finalized.++ *  Finalization means (a) arrange that subsequent calls+    to 'deRefWeak' return 'Nothing'; and (b) run the finalizer.++This behaviour depends on what it means for a key to be reachable.+Informally, something is reachable if it can be reached by following+ordinary pointers from the root set, but not following weak pointers.+We define reachability more precisely as follows.++A heap object is /reachable/ if:++ * It is a member of the /root set/.++ * It is directly pointed to by a reachable object, other than+   a weak pointer object.++ * It is a weak pointer object whose key is reachable.++ * It is the value or finalizer of a weak pointer object whose key is reachable.+-}++{- $notes++A finalizer is not always called after its weak pointer\'s object becomes+unreachable. If the object becomes unreachable right before the program exits,+then GC may not be performed. Finalizers run during GC, so finalizers associated+with the object do not run if GC does not happen.++Other than the above caveat, users can always expect that a finalizer will be+run after its weak pointer\'s object becomes unreachable.++If a finalizer throws an exception, the exception is silently caught without+notice. See the commit of issue+<https://gitlab.haskell.org/ghc/ghc/-/issues/13167 13167> for details. Writing a+finalizer that throws exceptions is discouraged.++-}
+ src/System/Posix/Internals.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module      :  System.Posix.Internals+-- Copyright   :  (c) The University of Glasgow, 1992-2002+-- License     :  see libraries/base/LICENSE+--+-- Maintainer  :  ghc-devs@haskell.org+-- Stability   :  internal+-- Portability :  non-portable (requires POSIX)+--+-- POSIX support layer for the standard libraries.+--+-- /The API of this module is unstable and not meant to be consumed by the general public./+-- If you absolutely must depend on it, make sure to use a tight upper+-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can+-- change rapidly without much warning.+--+-- This module is built on *every* platform, including Win32.+--+-- Non-POSIX compliant in order to support the following features:+--  * S_ISSOCK (no sockets in POSIX)+--++module System.Posix.Internals+  ( module GHC.Internal.System.Posix.Internals -- TODO: deprecate+  ) where++import GHC.Internal.System.Posix.Internals
+ src/System/Posix/Types.hs view
@@ -0,0 +1,25 @@+-- |+--+-- Module      :  System.Posix.Types+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (requires POSIX)+--+-- POSIX data types: Haskell equivalents of the types defined by the+-- @\<sys\/types.h>@ C header on a POSIX system.+--++module System.Posix.Types+    (-- *  POSIX data types+     -- **  Platform differences+     -- |  This module contains platform specific information about types.+     -- __/As such the types presented on this page reflect the platform+     -- on which the documentation was generated and may not coincide with+     -- the types on your platform./__+     module GHC.Internal.System.Posix.Types+     ) where++import GHC.Internal.System.Posix.Types
+ src/System/Timeout.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}++-------------------------------------------------------------------------------+-- |+-- Module      :  System.Timeout+-- Copyright   :  (c) The University of Glasgow 2007+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable+--+-- Attach a timeout event to arbitrary 'IO' computations.+--+-------------------------------------------------------------------------------+-- TODO: Inspect is still suitable.+module System.Timeout ( Timeout, timeout ) where++#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)+import GHC.Internal.Control.Monad+import GHC.Internal.Event           (getSystemTimerManager,+                            registerTimeout, unregisterTimeout)+#endif++import Control.Concurrent+import GHC.Internal.Control.Exception   (Exception(..), handleJust, bracket,+                            uninterruptibleMask_,+                            asyncExceptionToException,+                            asyncExceptionFromException)+import GHC.Internal.Data.Unique         (Unique, newUnique)+import GHC.Conc (labelThread)+import Prelude++-- $setup+-- >>> import Prelude+-- >>> import Control.Concurrent (threadDelay)++-- An internal type that is thrown as a dynamic exception to+-- interrupt the running IO computation when the timeout has+-- expired.++-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out+-- computation.+--+-- @since 4.0+newtype Timeout = Timeout Unique deriving Eq++-- | @since 4.0+instance Show Timeout where+    show _ = "<<timeout>>"++-- Timeout is a child of SomeAsyncException+-- | @since 4.7.0.0+instance Exception Timeout where+  toException = asyncExceptionToException+  fromException = asyncExceptionFromException++-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result+-- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result+-- is available before the timeout expires, @Just a@ is returned. A negative+-- timeout interval means \"wait indefinitely\". When specifying long timeouts,+-- be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only+-- 2147483647 μs, less than 36 minutes.+-- Consider using @Control.Concurrent.Timeout.timeout@ from @unbounded-delays@ package.+--+-- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time")+-- Just "finished on time"+--+-- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time")+-- Nothing+--+-- The design of this combinator was guided by the objective that @timeout n f@+-- should behave exactly the same as @f@ as long as @f@ doesn't time out. This+-- means that @f@ has the same 'myThreadId' it would have without the timeout+-- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate+-- further up. It also possible for @f@ to receive exceptions thrown to it by+-- another thread.+--+-- A tricky implementation detail is the question of how to abort an @IO@+-- computation. This combinator relies on asynchronous exceptions internally+-- (namely throwing the computation the 'Timeout' exception).  The technique+-- works very well for computations executing inside of the Haskell runtime+-- system, but it doesn't work at all for non-Haskell code.  Foreign function+-- calls, for example, cannot be timed out with this combinator simply because+-- an arbitrary C function cannot receive asynchronous exceptions. When+-- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be+-- delivered until the FFI call returns, which pretty much negates the purpose+-- of the combinator. In practice, however, this limitation is less severe than+-- it may sound. Standard I\/O functions like 'GHC.Internal.System.IO.hGetBuf',+-- 'GHC.Internal.System.IO.hPutBuf', Network.Socket.accept, or 'GHC.Internal.System.IO.hWaitForInput'+-- appear to be blocking, but they really don't because the runtime system uses+-- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it+-- is possible to interrupt standard socket I\/O or file I\/O using this+-- combinator.+---+-- Note that 'timeout' cancels the computation by throwing it the 'Timeout'+-- exception. Consequently blanket exception handlers (e.g. catching+-- 'SomeException') within the computation will break the timeout behavior.+timeout :: Int -> IO a -> IO (Maybe a)+timeout n f+    | n <  0    = fmap Just f+    | n == 0    = return Nothing+#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)+    | rtsSupportsBoundThreads = do+        -- In the threaded RTS, we use the Timer Manager to delay the+        -- (fairly expensive) 'forkIO' call until the timeout has expired.+        --+        -- An additional thread is required for the actual delivery of+        -- the Timeout exception because killThread (or another throwTo)+        -- is the only way to reliably interrupt a throwTo in flight.+        pid <- myThreadId+        ex  <- fmap Timeout newUnique+        tm  <- getSystemTimerManager+        -- 'lock' synchronizes the timeout handler and the main thread:+        --  * the main thread can disable the handler by writing to 'lock';+        --  * the handler communicates the spawned thread's id through 'lock'.+        -- These two cases are mutually exclusive.+        lock <- newEmptyMVar+        let handleTimeout = do+                v <- isEmptyMVar lock+                when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do+                    tid <- myThreadId+                    labelThread tid "timeout worker"+                    v2 <- tryPutMVar lock tid+                    when v2 $ throwTo pid ex+            cleanupTimeout key = uninterruptibleMask_ $ do+                v <- tryPutMVar lock undefined+                if v then unregisterTimeout tm key+                     else takeMVar lock >>= killThread+        handleJust (\e -> if e == ex then Just () else Nothing)+                   (\_ -> return Nothing)+                   (bracket (registerTimeout tm n handleTimeout)+                            cleanupTimeout+                            (\_ -> fmap Just f))+#endif+    | otherwise = do+        pid <- myThreadId+        ex  <- fmap Timeout newUnique+        handleJust (\e -> if e == ex then Just () else Nothing)+                   (\_ -> return Nothing)+                   (bracket (forkIOWithUnmask $ \unmask -> do+                                 tid <- myThreadId+                                 labelThread tid "timeout worker"+                                 unmask $ threadDelay n >> throwTo pid ex)+                            (uninterruptibleMask_ . killThread)+                            (\_ -> fmap Just f))+        -- #7719 explains why we need uninterruptibleMask_ above.
+ src/Text/ParserCombinators/ReadP.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Text.ParserCombinators.ReadP+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (local universal quantification)+--+-- This is a module of parser combinators, originally written by Koen Claessen.+-- It parses all alternatives in parallel, so it never keeps hold of+-- the beginning of the input string, a common source of space leaks with+-- other parsers.  The @('+++')@ choice combinator is genuinely commutative;+-- it makes no difference which branch is \"shorter\".++module Text.ParserCombinators.ReadP+    (-- *  The 'ReadP' type+     ReadP,+     -- *  Primitive operations+     get,+     look,+     (+++),+     (<++),+     gather,+     -- *  Other operations+     pfail,+     eof,+     satisfy,+     char,+     string,+     munch,+     munch1,+     skipSpaces,+     choice,+     count,+     between,+     option,+     optional,+     many,+     many1,+     skipMany,+     skipMany1,+     sepBy,+     sepBy1,+     endBy,+     endBy1,+     chainr,+     chainl,+     chainl1,+     chainr1,+     manyTill,+     -- *  Running a parser+     ReadS,+     readP_to_S,+     readS_to_P,+     -- *  Properties+     -- $properties+     ) where++import GHC.Internal.Text.ParserCombinators.ReadP
+ src/Text/ParserCombinators/ReadPrec.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Text.ParserCombinators.ReadPrec+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)+--+-- This module defines parser combinators for precedence parsing.++module Text.ParserCombinators.ReadPrec+    (ReadPrec,+     -- *  Precedences+     Prec,+     minPrec,+     -- *  Precedence operations+     lift,+     prec,+     step,+     reset,+     -- *  Other operations+     -- |  All are based directly on their similarly-named 'ReadP' counterparts.+     get,+     look,+     (+++),+     (<++),+     pfail,+     choice,+     -- *  Converters+     readPrec_to_P,+     readP_to_Prec,+     readPrec_to_S,+     readS_to_Prec+     ) where++import GHC.Internal.Text.ParserCombinators.ReadPrec
+ src/Text/Printf.hs view
@@ -0,0 +1,919 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Printf+-- Copyright   :  (c) Lennart Augustsson and Bart Massey 2013+-- License     :  BSD-style (see the file LICENSE in this distribution)+--+-- Maintainer  :  Bart Massey <bart@cs.pdx.edu>+-- Stability   :  provisional+-- Portability :  portable+--+-- A C @printf(3)@-like formatter. This version has been+-- extended by Bart Massey as per the recommendations of+-- John Meacham and Simon Marlow+-- <http://comments.gmane.org/gmane.comp.lang.haskell.libraries/4726>+-- to support extensible formatting for new datatypes.  It+-- has also been extended to support almost all C+-- @printf(3)@ syntax.+-----------------------------------------------------------------------------++module Text.Printf(+-- * Printing Functions+   printf, hPrintf,+-- * Extending To New Types+--+-- | This 'printf' can be extended to format types+-- other than those provided for by default. This+-- is done by instantiating 'PrintfArg' and providing+-- a 'formatArg' for the type. It is possible to+-- provide a 'parseFormat' to process type-specific+-- modifiers, but the default instance is usually+-- the best choice.+--+-- For example:+--+-- > instance PrintfArg () where+-- >   formatArg x fmt | fmtChar (vFmt 'U' fmt) == 'U' =+-- >     formatString "()" (fmt { fmtChar = 's', fmtPrecision = Nothing })+-- >   formatArg _ fmt = errorBadFormat $ fmtChar fmt+-- >+-- > main :: IO ()+-- > main = printf "[%-3.1U]\n" ()+--+-- prints \"@[() ]@\". Note the use of 'formatString' to+-- take care of field formatting specifications in a convenient+-- way.+   PrintfArg(..),+   FieldFormatter,+   FieldFormat(..),+   FormatAdjustment(..), FormatSign(..),+   vFmt,+-- ** Handling Type-specific Modifiers+--+-- | In the unlikely case that modifier characters of+-- some kind are desirable for a user-provided type,+-- a 'ModifierParser' can be provided to process these+-- characters. The resulting modifiers will appear in+-- the 'FieldFormat' for use by the type-specific formatter.+   ModifierParser, FormatParse(..),+-- ** Standard Formatters+--+-- | These formatters for standard types are provided for+-- convenience in writing new type-specific formatters:+-- a common pattern is to throw to 'formatString' or+-- 'formatInteger' to do most of the format handling for+-- a new type.+   formatString, formatChar, formatInt,+   formatInteger, formatRealFloat,+-- ** Raising Errors+--+-- | These functions are used internally to raise various+-- errors, and are exported for use by new type-specific+-- formatters.+  errorBadFormat, errorShortFormat, errorMissingArgument,+  errorBadArgument,+  perror,+-- * Implementation Internals+-- | These types are needed for implementing processing+-- variable numbers of arguments to 'printf' and 'hPrintf'.+-- Their implementation is intentionally not visible from+-- this module. If you attempt to pass an argument of a type+-- which is not an instance of the appropriate class to+-- 'printf' or 'hPrintf', then the compiler will report it+-- as a missing instance of 'PrintfArg'.  (All 'PrintfArg'+-- instances are 'PrintfType' instances.)+  PrintfType, HPrintfType,+-- | This class is needed as a Haskell98 compatibility+-- workaround for the lack of FlexibleInstances.+  IsChar(..)+) where++import Prelude+import Data.Char+import GHC.Internal.Int+import GHC.Internal.Data.List (stripPrefix)+import GHC.Internal.Word+import GHC.Internal.Numeric+import GHC.Internal.Numeric.Natural+import GHC.Internal.System.IO++-- $setup+-- >>> import Prelude++-------------------++-- | Format a variable number of arguments with the C-style formatting string.+--+-- >>> printf "%s, %d, %.4f" "hello" 123 pi+-- hello, 123, 3.1416+--+-- The return value is either 'String' or @('IO' a)@ (which+-- should be @('IO' ())@, but Haskell's type system+-- makes this hard).+--+-- The format string consists of ordinary characters and+-- /conversion specifications/, which specify how to format+-- one of the arguments to 'printf' in the output string. A+-- format specification is introduced by the @%@ character;+-- this character can be self-escaped into the format string+-- using @%%@. A format specification ends with a+-- /format character/ that provides the primary information about+-- how to format the value. The rest of the conversion+-- specification is optional.  In order, one may have flag+-- characters, a width specifier, a precision specifier, and+-- type-specific modifier characters.+--+-- Unlike C @printf(3)@, the formatting of this 'printf'+-- is driven by the argument type; formatting is type specific. The+-- types formatted by 'printf' \"out of the box\" are:+--+--   * 'Integral' types, including 'Char'+--+--   * 'String'+--+--   * 'RealFloat' types+--+-- 'printf' is also extensible to support other types: see below.+--+-- A conversion specification begins with the+-- character @%@, followed by zero or more of the following flags:+--+-- > -      left adjust (default is right adjust)+-- > +      always use a sign (+ or -) for signed conversions+-- > space  leading space for positive numbers in signed conversions+-- > 0      pad with zeros rather than spaces+-- > #      use an \"alternate form\": see below+--+-- When both flags are given, @-@ overrides @0@ and @+@ overrides space.+-- A negative width specifier in a @*@ conversion is treated as+-- positive but implies the left adjust flag.+--+-- The \"alternate form\" for unsigned radix conversions is+-- as in C @printf(3)@:+--+-- > %o           prefix with a leading 0 if needed+-- > %x           prefix with a leading 0x if nonzero+-- > %X           prefix with a leading 0X if nonzero+-- > %b           prefix with a leading 0b if nonzero+-- > %[eEfFgG]    ensure that the number contains a decimal point+--+-- Any flags are followed optionally by a field width:+--+-- > num    field width+-- > *      as num, but taken from argument list+--+-- The field width is a minimum, not a maximum: it will be+-- expanded as needed to avoid mutilating a value.+--+-- Any field width is followed optionally by a precision:+--+-- > .num   precision+-- > .      same as .0+-- > .*     as num, but taken from argument list+--+-- Negative precision is taken as 0. The meaning of the+-- precision depends on the conversion type.+--+-- > Integral    minimum number of digits to show+-- > RealFloat   number of digits after the decimal point+-- > String      maximum number of characters+--+-- The precision for Integral types is accomplished by zero-padding.+-- If both precision and zero-pad are given for an Integral field,+-- the zero-pad is ignored.+--+-- Any precision is followed optionally for Integral types+-- by a width modifier; the only use of this modifier being+-- to set the implicit size of the operand for conversion of+-- a negative operand to unsigned:+--+-- > hh     Int8+-- > h      Int16+-- > l      Int32+-- > ll     Int64+-- > L      Int64+--+-- The specification ends with a format character:+--+-- > c      character               Integral+-- > d      decimal                 Integral+-- > o      octal                   Integral+-- > x      hexadecimal             Integral+-- > X      hexadecimal             Integral+-- > b      binary                  Integral+-- > u      unsigned decimal        Integral+-- > f      floating point          RealFloat+-- > F      floating point          RealFloat+-- > g      general format float    RealFloat+-- > G      general format float    RealFloat+-- > e      exponent format float   RealFloat+-- > E      exponent format float   RealFloat+-- > s      string                  String+-- > v      default format          any type+--+-- The \"%v\" specifier is provided for all built-in types,+-- and should be provided for user-defined type formatters+-- as well. It picks a \"best\" representation for the given+-- type. For the built-in types the \"%v\" specifier is+-- converted as follows:+--+-- > c      Char+-- > u      other unsigned Integral+-- > d      other signed Integral+-- > g      RealFloat+-- > s      String+--+-- Mismatch between the argument types and the format+-- string, as well as any other syntactic or semantic errors+-- in the format string, will cause an exception to be+-- thrown at runtime.+--+-- Note that the formatting for 'RealFloat' types is+-- currently a bit different from that of C @printf(3)@,+-- conforming instead to 'GHC.Internal.Numeric.showEFloat',+-- 'GHC.Internal.Numeric.showFFloat' and 'GHC.Internal.Numeric.showGFloat' (and their+-- alternate versions 'GHC.Internal.Numeric.showFFloatAlt' and+-- 'GHC.Internal.Numeric.showGFloatAlt'). This is hard to fix: the fixed+-- versions would format in a backward-incompatible way.+-- In any case the Haskell behavior is generally more+-- sensible than the C behavior.  A brief summary of some+-- key differences:+--+-- * Haskell 'printf' never uses the default \"6-digit\" precision+--   used by C printf.+--+-- * Haskell 'printf' treats the \"precision\" specifier as+--   indicating the number of digits after the decimal point.+--+-- * Haskell 'printf' prints the exponent of e-format+--   numbers without a gratuitous plus sign, and with the+--   minimum possible number of digits.+--+-- * Haskell 'printf' will place a zero after a decimal point when+--   possible.+printf :: (PrintfType r) => String -> r+printf fmts = spr fmts []++-- | Similar to 'printf', except that output is via the specified+-- 'Handle'.  The return type is restricted to @('IO' a)@.+hPrintf :: (HPrintfType r) => Handle -> String -> r+hPrintf hdl fmts = hspr hdl fmts []++-- |The 'PrintfType' class provides the variable argument magic for+-- 'printf'.  Its implementation is intentionally not visible from+-- this module. If you attempt to pass an argument of a type which+-- is not an instance of this class to 'printf' or 'hPrintf', then+-- the compiler will report it as a missing instance of 'PrintfArg'.+class PrintfType t where+    spr :: String -> [UPrintf] -> t++-- | The 'HPrintfType' class provides the variable argument magic for+-- 'hPrintf'.  Its implementation is intentionally not visible from+-- this module.+class HPrintfType t where+    hspr :: Handle -> String -> [UPrintf] -> t++{- not allowed in Haskell 2010+instance PrintfType String where+    spr fmt args = uprintf fmt (reverse args)+-}+-- | @since 2.01+instance (IsChar c) => PrintfType [c] where+    spr fmts args = map fromChar (uprintf fmts (reverse args))++-- Note that this should really be (IO ()), but GHC's+-- type system won't readily let us say that without+-- bringing the GADTs. So we go conditional for these defs.++-- | @since 4.7.0.0+instance (a ~ ()) => PrintfType (IO a) where+    spr fmts args =+        putStr $ map fromChar $ uprintf fmts $ reverse args++-- | @since 4.7.0.0+instance (a ~ ()) => HPrintfType (IO a) where+    hspr hdl fmts args =+        hPutStr hdl (uprintf fmts (reverse args))++-- | @since 2.01+instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where+    spr fmts args = \ a -> spr fmts+                             ((parseFormat a, formatArg a) : args)++-- | @since 2.01+instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where+    hspr hdl fmts args = \ a -> hspr hdl fmts+                                  ((parseFormat a, formatArg a) : args)++-- | Typeclass of 'printf'-formattable values. The 'formatArg' method+-- takes a value and a field format descriptor and either fails due+-- to a bad descriptor or produces a 'ShowS' as the result. The+-- default 'parseFormat' expects no modifiers: this is the normal+-- case. Minimal instance: 'formatArg'.+class PrintfArg a where+    -- | @since 4.7.0.0+    formatArg :: a -> FieldFormatter+    -- | @since 4.7.0.0+    parseFormat :: a -> ModifierParser+    parseFormat _ (c : cs) = FormatParse "" c cs+    parseFormat _ "" = errorShortFormat++-- | @since 2.01+instance PrintfArg Char where+    formatArg = formatChar+    parseFormat _ cf = parseIntFormat (undefined :: Int) cf++-- | @since 2.01+instance (IsChar c) => PrintfArg [c] where+    formatArg = formatString++-- | @since 2.01+instance PrintfArg Int where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Int8 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Int16 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Int32 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Int64 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Word where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Word8 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Word16 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Word32 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Word64 where+    formatArg = formatInt+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Integer where+    formatArg = formatInteger+    parseFormat = parseIntFormat++-- | @since 4.8.0.0+instance PrintfArg Natural where+    formatArg = formatInteger . toInteger+    parseFormat = parseIntFormat++-- | @since 2.01+instance PrintfArg Float where+    formatArg = formatRealFloat++-- | @since 2.01+instance PrintfArg Double where+    formatArg = formatRealFloat++-- | This class, with only the one instance, is used as+-- a workaround for the fact that 'String', as a concrete+-- type, is not allowable as a typeclass instance. 'IsChar'+-- is exported for backward-compatibility.+class IsChar c where+    -- | @since 4.7.0.0+    toChar :: c -> Char+    -- | @since 4.7.0.0+    fromChar :: Char -> c++-- | @since 2.01+instance IsChar Char where+    toChar c = c+    fromChar c = c++-------------------++-- | Whether to left-adjust or zero-pad a field. These are+-- mutually exclusive, with 'LeftAdjust' taking precedence.+--+-- @since 4.7.0.0+data FormatAdjustment = LeftAdjust | ZeroPad++-- | How to handle the sign of a numeric field.  These are+-- mutually exclusive, with 'SignPlus' taking precedence.+--+-- @since 4.7.0.0+data FormatSign = SignPlus | SignSpace++-- | Description of field formatting for 'formatArg'. See UNIX @printf(3)@+-- for a description of how field formatting works.+--+-- @since 4.7.0.0+data FieldFormat = FieldFormat {+  fmtWidth :: Maybe Int,       -- ^ Total width of the field.+  fmtPrecision :: Maybe Int,   -- ^ Secondary field width specifier.+  fmtAdjust :: Maybe FormatAdjustment,  -- ^ Kind of filling or padding+                                        --   to be done.+  fmtSign :: Maybe FormatSign, -- ^ Whether to insist on a+                               -- plus sign for positive+                               -- numbers.+  fmtAlternate :: Bool,        -- ^ Indicates an "alternate+                               -- format".  See @printf(3)@+                               -- for the details, which+                               -- vary by argument spec.+  fmtModifiers :: String,      -- ^ Characters that appeared+                               -- immediately to the left of+                               -- 'fmtChar' in the format+                               -- and were accepted by the+                               -- type's 'parseFormat'.+                               -- Normally the empty string.+  fmtChar :: Char              -- ^ The format character+                               -- 'printf' was invoked+                               -- with. 'formatArg' should+                               -- fail unless this character+                               -- matches the type. It is+                               -- normal to handle many+                               -- different format+                               -- characters for a single+                               -- type.+  }++-- | The \"format parser\" walks over argument-type-specific+-- modifier characters to find the primary format character.+-- This is the type of its result.+--+-- @since 4.7.0.0+data FormatParse = FormatParse {+  fpModifiers :: String,   -- ^ Any modifiers found.+  fpChar :: Char,          -- ^ Primary format character.+  fpRest :: String         -- ^ Rest of the format string.+  }++-- Contains the "modifier letters" that can precede an+-- integer type.+intModifierMap :: [(String, Integer)]+intModifierMap = [+  ("hh", toInteger (minBound :: Int8)),+  ("h", toInteger (minBound :: Int16)),+  ("l", toInteger (minBound :: Int32)),+  ("ll", toInteger (minBound :: Int64)),+  ("L", toInteger (minBound :: Int64)) ]++parseIntFormat :: a -> String -> FormatParse+parseIntFormat _ s =+  case foldr matchPrefix Nothing intModifierMap of+    Just m -> m+    Nothing ->+      case s of+        c : cs -> FormatParse "" c cs+        "" -> errorShortFormat+  where+    matchPrefix (p, _) m@(Just (FormatParse p0 _ _))+      | length p0 >= length p = m+      | otherwise = case getFormat p of+          Nothing -> m+          Just fp -> Just fp+    matchPrefix (p, _) Nothing =+      getFormat p+    getFormat p =+      stripPrefix p s >>= fp+      where+        fp (c : cs) = Just $ FormatParse p c cs+        fp "" = errorShortFormat++-- | This is the type of a field formatter reified over its+-- argument.+--+-- @since 4.7.0.0+type FieldFormatter = FieldFormat -> ShowS++-- | Type of a function that will parse modifier characters+-- from the format string.+--+-- @since 4.7.0.0+type ModifierParser = String -> FormatParse++-- | Substitute a \'v\' format character with the given+-- default format character in the 'FieldFormat'. A+-- convenience for user-implemented types, which should+-- support \"%v\".+--+-- @since 4.7.0.0+vFmt :: Char -> FieldFormat -> FieldFormat+vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c}+vFmt _ ufmt = ufmt++-- | Formatter for 'Char' values.+--+-- @since 4.7.0.0+formatChar :: Char -> FieldFormatter+formatChar x ufmt =+  formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt++-- | Formatter for 'String' values.+--+-- @since 4.7.0.0+formatString :: IsChar a => [a] -> FieldFormatter+formatString x ufmt =+  case fmtChar $ vFmt 's' ufmt of+    's' -> map toChar . (adjust ufmt ("", ts) ++)+           where+             ts = map toChar $ trunc $ fmtPrecision ufmt+               where+                 trunc Nothing = x+                 trunc (Just n) = take n x+    c   -> errorBadFormat c++-- Possibly apply the int modifiers to get a new+-- int width for conversion.+fixupMods :: FieldFormat -> Maybe Integer -> Maybe Integer+fixupMods ufmt m =+  let mods = fmtModifiers ufmt in+  case mods of+    "" -> m+    _ -> case lookup mods intModifierMap of+      Just m0 -> Just m0+      Nothing -> perror "unknown format modifier"++-- | Formatter for 'Int' values.+--+-- @since 4.7.0.0+formatInt :: (Integral a, Bounded a) => a -> FieldFormatter+formatInt x ufmt =+  let lb = toInteger $ minBound `asTypeOf` x+      m = fixupMods ufmt (Just lb)+      ufmt' = case lb of+        0 -> vFmt 'u' ufmt+        _ -> ufmt+  in+  formatIntegral m (toInteger x) ufmt'++-- | Formatter for 'Integer' values.+--+-- @since 4.7.0.0+formatInteger :: Integer -> FieldFormatter+formatInteger x ufmt =+  let m = fixupMods ufmt Nothing in+  formatIntegral m x ufmt++-- All formatting for integral types is handled+-- consistently.  The only difference is between Integer and+-- bounded types; this difference is handled by the 'm'+-- argument containing the lower bound.+formatIntegral :: Maybe Integer -> Integer -> FieldFormatter+formatIntegral m x ufmt0 =+  let prec = fmtPrecision ufmt0 in+  case fmtChar ufmt of+    'd' -> (adjustSigned ufmt (fmti prec x) ++)+    'i' -> (adjustSigned ufmt (fmti prec x) ++)+    'x' -> (adjust ufmt (fmtu 16 (alt "0x" x) prec m x) ++)+    'X' -> (adjust ufmt (upcase $ fmtu 16 (alt "0X" x) prec m x) ++)+    'b' -> (adjust ufmt (fmtu 2 (alt "0b" x) prec m x) ++)+    'o' -> (adjust ufmt (fmtu 8 (alt "0" x) prec m x) ++)+    'u' -> (adjust ufmt (fmtu 10 Nothing prec m x) ++)+    'c' | x >= fromIntegral (ord (minBound :: Char)) &&+          x <= fromIntegral (ord (maxBound :: Char)) &&+          fmtPrecision ufmt == Nothing &&+          fmtModifiers ufmt == "" ->+            formatString [chr $ fromIntegral x] (ufmt { fmtChar = 's' })+    'c' -> perror "illegal char conversion"+    c   -> errorBadFormat c+  where+    ufmt = vFmt 'd' $ case ufmt0 of+      FieldFormat { fmtPrecision = Just _, fmtAdjust = Just ZeroPad } ->+        ufmt0 { fmtAdjust = Nothing }+      _ -> ufmt0+    alt _ 0 = Nothing+    alt p _ = case fmtAlternate ufmt of+      True -> Just p+      False -> Nothing+    upcase (s1, s2) = (s1, map toUpper s2)++-- | Formatter for 'RealFloat' values.+--+-- @since 4.7.0.0+formatRealFloat :: RealFloat a => a -> FieldFormatter+formatRealFloat x ufmt =+  let c = fmtChar $ vFmt 'g' ufmt+      prec = fmtPrecision ufmt+      alt = fmtAlternate ufmt+  in+   case c of+     'e' -> (adjustSigned ufmt (dfmt c prec alt x) ++)+     'E' -> (adjustSigned ufmt (dfmt c prec alt x) ++)+     'f' -> (adjustSigned ufmt (dfmt c prec alt x) ++)+     'F' -> (adjustSigned ufmt (dfmt c prec alt x) ++)+     'g' -> (adjustSigned ufmt (dfmt c prec alt x) ++)+     'G' -> (adjustSigned ufmt (dfmt c prec alt x) ++)+     _   -> errorBadFormat c++-- This is the type carried around for arguments in+-- the varargs code.+type UPrintf = (ModifierParser, FieldFormatter)++-- Given a format string and a list of formatting functions+-- (the actual argument value having already been baked into+-- each of these functions before delivery), return the+-- actual formatted text string.+uprintf :: String -> [UPrintf] -> String+uprintf s us = uprintfs s us ""++-- This function does the actual work, producing a ShowS+-- instead of a string, for future expansion and for+-- misguided efficiency.+uprintfs :: String -> [UPrintf] -> ShowS+uprintfs ""       []       = id+uprintfs ""       (_:_)    = errorShortFormat+uprintfs ('%':'%':cs) us   = ('%' :) . uprintfs cs us+uprintfs ('%':_)  []       = errorMissingArgument+uprintfs ('%':cs) us@(_:_) = fmt cs us+uprintfs (c:cs)   us       = (c :) . uprintfs cs us++-- Given a suffix of the format string starting just after+-- the percent sign, and the list of remaining unprocessed+-- arguments in the form described above, format the portion+-- of the output described by this field description, and+-- then continue with 'uprintfs'.+fmt :: String -> [UPrintf] -> ShowS+fmt cs0 us0 =+  case getSpecs False False Nothing False cs0 us0 of+    (_, _, []) -> errorMissingArgument+    (ufmt, cs, (_, u) : us) -> u ufmt . uprintfs cs us++-- Given field formatting information, and a tuple+-- consisting of a prefix (for example, a minus sign) that+-- is supposed to go before the argument value and a string+-- representing the value, return the properly padded and+-- formatted result.+adjust :: FieldFormat -> (String, String) -> String+adjust ufmt (pre, str) =+  let naturalWidth = length pre + length str+      zero = case fmtAdjust ufmt of+        Just ZeroPad -> True+        _ -> False+      left = case fmtAdjust ufmt of+        Just LeftAdjust -> True+        _ -> False+      fill = case fmtWidth ufmt of+        Just width | naturalWidth < width ->+          let fillchar = if zero then '0' else ' ' in+          replicate (width - naturalWidth) fillchar+        _ -> ""+  in+   if left+   then pre ++ str ++ fill+   else if zero+        then pre ++ fill ++ str+        else fill ++ pre ++ str++-- For positive numbers with an explicit sign field ("+" or+-- " "), adjust accordingly.+adjustSigned :: FieldFormat -> (String, String) -> String+adjustSigned ufmt@(FieldFormat {fmtSign = Just SignPlus}) ("", str) =+  adjust ufmt ("+", str)+adjustSigned ufmt@(FieldFormat {fmtSign = Just SignSpace}) ("", str) =+  adjust ufmt (" ", str)+adjustSigned ufmt ps =+  adjust ufmt ps++-- Format a signed integer in the "default" fashion.+-- This will be subjected to adjust subsequently.+fmti :: Maybe Int -> Integer -> (String, String)+fmti prec i+  | i < 0 = ("-", integral_prec prec (show (-i)))+  | otherwise = ("", integral_prec prec (show i))++-- Format an unsigned integer in the "default" fashion.+-- This will be subjected to adjust subsequently.  The 'b'+-- argument is the base, the 'pre' argument is the prefix,+-- and the '(Just m)' argument is the implicit lower-bound+-- size of the operand for conversion from signed to+-- unsigned. Thus, this function will refuse to convert an+-- unbounded negative integer to an unsigned string.+fmtu :: Integer -> Maybe String -> Maybe Int -> Maybe Integer -> Integer+     -> (String, String)+fmtu b (Just pre) prec m i =+  let ("", s) = fmtu b Nothing prec m i in+  case pre of+    "0" -> case s of+      '0' : _ -> ("", s)+      _ -> (pre, s)+    _ -> (pre, s)+fmtu b Nothing prec0 m0 i0 =+  case fmtu' prec0 m0 i0 of+    Just s -> ("", s)+    Nothing -> errorBadArgument+  where+    fmtu' :: Maybe Int -> Maybe Integer -> Integer -> Maybe String+    fmtu' prec (Just m) i | i < 0 =+      fmtu' prec Nothing (-2 * m + i)+    fmtu' (Just prec) _ i | i >= 0 =+      fmap (integral_prec (Just prec)) $ fmtu' Nothing Nothing i+    fmtu' Nothing _ i | i >= 0 =+      Just $ showIntAtBase b intToDigit i ""+    fmtu' _ _ _ = Nothing+++-- This is used by 'fmtu' and 'fmti' to zero-pad an+-- int-string to a required precision.+integral_prec :: Maybe Int -> String -> String+integral_prec Nothing integral = integral+integral_prec (Just 0) "0" = ""+integral_prec (Just prec) integral =+  replicate (prec - length integral) '0' ++ integral++stoi :: String -> (Int, String)+stoi cs =+  let (as, cs') = span isDigit cs in+  case as of+    "" -> (0, cs')+    _ -> (read as, cs')++-- Figure out the FormatAdjustment, given:+--   width, precision, left-adjust, zero-fill+adjustment :: Maybe Int -> Maybe a -> Bool -> Bool+           -> Maybe FormatAdjustment+adjustment w p l z =+  case w of+    Just n | n < 0 -> adjl p True z+    _ -> adjl p l z+  where+    adjl _ True _ = Just LeftAdjust+    adjl _ False True = Just ZeroPad+    adjl _ _ _ = Nothing++-- Parse the various format controls to get a format specification.+getSpecs :: Bool -> Bool -> Maybe FormatSign -> Bool -> String -> [UPrintf]+         -> (FieldFormat, String, [UPrintf])+getSpecs _ z s a ('-' : cs0) us = getSpecs True z s a cs0 us+getSpecs l z _ a ('+' : cs0) us = getSpecs l z (Just SignPlus) a cs0 us+getSpecs l z s a (' ' : cs0) us =+  getSpecs l z ss a cs0 us+  where+    ss = case s of+      Just SignPlus -> Just SignPlus+      _ -> Just SignSpace+getSpecs l _ s a ('0' : cs0) us = getSpecs l True s a cs0 us+getSpecs l z s _ ('#' : cs0) us = getSpecs l z s True cs0 us+getSpecs l z s a ('*' : cs0) us =+  let (us', n) = getStar us+      ((p, cs''), us'') = case cs0 of+        '.':'*':r ->+          let (us''', p') = getStar us' in ((Just p', r), us''')+        '.':r ->+          let (p', r') = stoi r in ((Just p', r'), us')+        _ ->+          ((Nothing, cs0), us')+      FormatParse ms c cs =+        case us'' of+          (ufmt, _) : _ -> ufmt cs''+          [] -> errorMissingArgument+  in+   (FieldFormat {+       fmtWidth = Just (abs n),+       fmtPrecision = p,+       fmtAdjust = adjustment (Just n) p l z,+       fmtSign = s,+       fmtAlternate = a,+       fmtModifiers = ms,+       fmtChar = c}, cs, us'')+getSpecs l z s a ('.' : cs0) us =+  let ((p, cs'), us') = case cs0 of+        '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')+        _ ->        (stoi cs0, us)+      FormatParse ms c cs =+        case us' of+          (ufmt, _) : _ -> ufmt cs'+          [] -> errorMissingArgument+  in+   (FieldFormat {+       fmtWidth = Nothing,+       fmtPrecision = Just p,+       fmtAdjust = adjustment Nothing (Just p) l z,+       fmtSign = s,+       fmtAlternate = a,+       fmtModifiers = ms,+       fmtChar = c}, cs, us')+getSpecs l z s a cs0@(c0 : _) us | isDigit c0 =+  let (n, cs') = stoi cs0+      ((p, cs''), us') = case cs' of+        '.' : '*' : r ->+          let (us'', p') = getStar us in ((Just p', r), us'')+        '.' : r ->+          let (p', r') = stoi r in ((Just p', r'), us)+        _ ->+          ((Nothing, cs'), us)+      FormatParse ms c cs =+        case us' of+          (ufmt, _) : _ -> ufmt cs''+          [] -> errorMissingArgument+  in+   (FieldFormat {+       fmtWidth = Just (abs n),+       fmtPrecision = p,+       fmtAdjust = adjustment (Just n) p l z,+       fmtSign = s,+       fmtAlternate = a,+       fmtModifiers = ms,+       fmtChar = c}, cs, us')+getSpecs l z s a cs0@(_ : _) us =+  let FormatParse ms c cs =+        case us of+          (ufmt, _) : _ -> ufmt cs0+          [] -> errorMissingArgument+  in+   (FieldFormat {+       fmtWidth = Nothing,+       fmtPrecision = Nothing,+       fmtAdjust = adjustment Nothing Nothing l z,+       fmtSign = s,+       fmtAlternate = a,+       fmtModifiers = ms,+       fmtChar = c}, cs, us)+getSpecs _ _ _ _ ""       _  =+  errorShortFormat++-- Process a star argument in a format specification.+getStar :: [UPrintf] -> ([UPrintf], Int)+getStar us =+  let ufmt = FieldFormat {+        fmtWidth = Nothing,+        fmtPrecision = Nothing,+        fmtAdjust = Nothing,+        fmtSign = Nothing,+        fmtAlternate = False,+        fmtModifiers = "",+        fmtChar = 'd' } in+  case us of+    [] -> errorMissingArgument+    (_, nu) : us' -> (us', read (nu ufmt ""))++-- Format a RealFloat value.+dfmt :: (RealFloat a) => Char -> Maybe Int -> Bool -> a -> (String, String)+dfmt c p a d =+  let caseConvert = if isUpper c then map toUpper else id+      showFunction = case toLower c of+        'e' -> showEFloat+        'f' -> if a then showFFloatAlt else showFFloat+        'g' -> if a then showGFloatAlt else showGFloat+        _   -> perror "internal error: impossible dfmt"+      result = caseConvert $ showFunction p d ""+  in+   case result of+     '-' : cs -> ("-", cs)+     cs       -> ("" , cs)+++-- | Raises an 'error' with a printf-specific prefix on the+-- message string.+--+-- @since 4.7.0.0+perror :: String -> a+perror s = errorWithoutStackTrace $ "printf: " ++ s++-- | Calls 'perror' to indicate an unknown format letter for+-- a given type.+--+-- @since 4.7.0.0+errorBadFormat :: Char -> a+errorBadFormat c = perror $ "bad formatting char " ++ show c++errorShortFormat, errorMissingArgument, errorBadArgument :: a+-- | Calls 'perror' to indicate that the format string ended+-- early.+--+-- @since 4.7.0.0+errorShortFormat = perror "formatting string ended prematurely"+-- | Calls 'perror' to indicate that there is a missing+-- argument in the argument list.+--+-- @since 4.7.0.0+errorMissingArgument = perror "argument list ended prematurely"+-- | Calls 'perror' to indicate that there is a type+-- error or similar in the given argument.+--+-- @since 4.7.0.0+errorBadArgument = perror "bad argument"
+ src/Text/Read.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Text.Read+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)+--+-- Converting strings to values.+--+-- The "Text.Read" module is the canonical place to import for+-- 'Read'-class facilities.  For GHC only, it offers an extended and much+-- improved 'Read' class, which constitutes a proposed alternative to the+-- Haskell 2010 'Read'.  In particular, writing parsers is easier, and+-- the parsers are much more efficient.+--++module Text.Read+    (-- *  The 'Read' class+     Read(..),+     ReadS,+     -- *  Haskell 2010 functions+     reads,+     read,+     readParen,+     lex,+     -- *  New parsing functions+     module Text.ParserCombinators.ReadPrec,+     Lexeme(..),+     lexP,+     parens,+     readListDefault,+     readListPrecDefault,+     readEither,+     readMaybe+     ) where++import GHC.Internal.Text.Read+import Text.ParserCombinators.ReadPrec
+ src/Text/Read/Lex.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Text.Read.Lex+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)+--+-- The cut-down Haskell lexer, used by Text.Read+--++module Text.Read.Lex+    (Lexeme(..),+     Number,+     numberToInteger,+     numberToFixed,+     numberToRational,+     numberToRangedRational,+     lex,+     expect,+     hsLex,+     lexChar,+     readBinP,+     readIntP,+     readOctP,+     readDecP,+     readHexP,+     isSymbolChar+     ) where++import GHC.Internal.Text.Read.Lex
+ src/Text/Show.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}++-- |+--+-- Module      :  Text.Show+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Converting values to readable strings:+-- the 'Show' class and associated functions.+--++module Text.Show+    (ShowS,+     Show(showsPrec, show, showList),+     shows,+     showChar,+     showString,+     showParen,+     showListWith+     ) where++import GHC.Internal.Text.Show
+ src/Text/Show/Functions.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}+-- This module deliberately declares orphan instances:+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+--+-- Module      :  Text.Show.Functions+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Optional instance of 'Text.Show.Show' for functions:+--+-- > instance Show (a -> b) where+-- >    showsPrec _ _ = showString "<function>"+--++module Text.Show.Functions () where++import Prelude++-- | @since 2.01+instance Show (a -> b) where+        showsPrec _ _ = showString "<function>"
+ src/Type/Reflection.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE MagicHash #-}++-- |+--+-- Module      :  Type.Reflection+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2017+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  stable+-- Portability :  non-portable (requires GADTs and compiler support)+--+-- This provides a type-indexed type representation mechanism, similar to that+-- described by,+--+-- * Simon Peyton-Jones, Stephanie Weirich, Richard Eisenberg,+-- Dimitrios Vytiniotis. "<https://www.microsoft.com/en-us/research/wp-content/uploads/2016/08/dynamic.pdf A reflection on types>".+-- /Proc. Philip Wadler's 60th birthday Festschrift/, Edinburgh (April 2016).+--+-- The interface provides 'I.TypeRep', a type representation which can+-- be safely decomposed and composed. See "Data.Dynamic" for an example of this.+--+-- @since 4.10.0.0+--++module Type.Reflection+    (-- *  The Typeable class+     Typeable,+     typeRep,+     withTypeable,+     -- *  Propositional equality+     (:~:)(Refl),+     (:~~:)(HRefl),+     -- *  Type representations+     -- **  Type-Indexed+     TypeRep,+     pattern TypeRep,+     typeOf,+     pattern App,+     pattern Con,+     pattern Con',+     pattern Fun,+     typeRepTyCon,+     rnfTypeRep,+     eqTypeRep,+     decTypeRep,+     typeRepKind,+     splitApps,+     -- **  Quantified+     SomeTypeRep(..),+     someTypeRep,+     someTypeRepTyCon,+     rnfSomeTypeRep,+     -- *  Type constructors+     TyCon,+     tyConPackage,+     tyConModule,+     tyConName,+     rnfTyCon,+     -- *  Module names+     Module,+     moduleName,+     modulePackage,+     rnfModule+     ) where++import GHC.Internal.Type.Reflection
+ src/Type/Reflection/Unsafe.hs view
@@ -0,0 +1,33 @@+-- |+--+-- Module      :  Type.Reflection.Unsafe+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2015+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- The representations of the types 'TyCon' and 'TypeRep', and the function+-- 'mkTyCon' which is used by derived instances of 'Typeable' to construct+-- 'TyCon's.+--+-- Be warned, these functions can be used to construct ill-kinded+-- type representations.+--++module Type.Reflection.Unsafe+    (-- *  Type representations+     TypeRep,+     mkTrApp,+     mkTyCon,+     typeRepFingerprint,+     someTypeRepFingerprint,+     -- *  Kind representations+     KindRep(..),+     TypeLitSort(..),+     -- *  Type constructors+     TyCon,+     mkTrCon,+     tyConKindRep,+     tyConKindArgs,+     tyConFingerprint+     ) where++import GHC.Internal.Type.Reflection.Unsafe
+ src/Unsafe/Coerce.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MagicHash #-}++module Unsafe.Coerce+    (unsafeCoerce,+     unsafeCoerceUnlifted,+     unsafeCoerceAddr,+     unsafeEqualityProof,+     UnsafeEquality(..),+     unsafeCoerce#+     ) where++import GHC.Internal.Unsafe.Coerce