packages feed

base 3.0.3.2 → 4.0.0.0

raw patch · 179 files changed

+57606/−383 lines, 179 filesdep +ghc-primdep +integerdep +rtsdep −basedep −sybsetup-changed

Dependencies added: ghc-prim, integer, rts

Dependencies removed: base, syb

Files

Control/Applicative.hs view
@@ -1,2 +1,220 @@-module Control.Applicative (module X___) where-import "base" Control.Applicative as X___+-----------------------------------------------------------------------------+-- |+-- 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: it provides pure expressions and sequencing, but no binding.+-- (Technically, a strong lax monoidal functor.)  For more details, see+-- /Applicative Programming with Effects/,+-- by Conor McBride and Ross Paterson, online at+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+-- 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 recent parsing work by Doaitse Swierstra.+--+-- This class is also useful with instances of the+-- 'Data.Traversable.Traversable' class.++module Control.Applicative (+        -- * Applicative functors+        Applicative(..),+        -- * Alternatives+        Alternative(..),+        -- * Instances+        Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),+        -- * Utility functions+        (<$>), (<$), (*>), (<*), (<**>),+        liftA, liftA2, liftA3,+        optional, some, many+        ) where++import Prelude hiding (id,(.))+import qualified Prelude++import Control.Category+import Control.Arrow+        (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>)))+import Control.Monad (liftM, ap, MonadPlus(..))+import Control.Monad.Instances ()+import Data.Monoid (Monoid(..))++infixl 3 <|>+infixl 4 <$>, <$+infixl 4 <*>, <*, *>, <**>++-- | A functor with application.+--+-- Instances should satisfy the following laws:+--+-- [/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 'Functor' instance should satisfy+--+-- @+--      'fmap' f x = 'pure' f '<*>' x+-- @+--+-- If @f@ is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@.++class Functor f => Applicative f where+        -- | Lift a value.+        pure :: a -> f a++        -- | Sequential application.+        (<*>) :: f (a -> b) -> f a -> f b++-- | A monoid on applicative functors.+class Applicative f => Alternative f where+        -- | The identity of '<|>'+        empty :: f a+        -- | An associative binary operation+        (<|>) :: f a -> f a -> f a++-- instances for Prelude types++instance Applicative Maybe where+        pure = return+        (<*>) = ap++instance Alternative Maybe where+        empty = Nothing+        Nothing <|> p = p+        Just x <|> _ = Just x++instance Applicative [] where+        pure = return+        (<*>) = ap++instance Alternative [] where+        empty = []+        (<|>) = (++)++instance Applicative IO where+        pure = return+        (<*>) = ap++instance Applicative ((->) a) where+        pure = const+        (<*>) f g x = f x (g x)++instance Monoid a => Applicative ((,) a) where+        pure x = (mempty, x)+        (u, f) <*> (v, x) = (u `mappend` v, f x)++-- new instances++newtype Const a b = Const { getConst :: a }++instance Functor (Const m) where+        fmap _ (Const v) = Const v++instance Monoid m => Applicative (Const m) where+        pure _ = Const mempty+        Const f <*> Const v = Const (f `mappend` v)++newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }++instance Monad m => Functor (WrappedMonad m) where+        fmap f (WrapMonad v) = WrapMonad (liftM f v)++instance Monad m => Applicative (WrappedMonad m) where+        pure = WrapMonad . return+        WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)++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 }++instance Arrow a => Functor (WrappedArrow a b) where+        fmap f (WrapArrow a) = WrapArrow (a >>> arr f)++instance Arrow a => Applicative (WrappedArrow a b) where+        pure x = WrapArrow (arr (const x))+        WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))++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, so that+--+-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@+--+newtype ZipList a = ZipList { getZipList :: [a] }++instance Functor ZipList where+        fmap f (ZipList xs) = ZipList (map f xs)++instance Applicative ZipList where+        pure x = ZipList (repeat x)+        ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)++-- extra functions++-- | A synonym for 'fmap'.+(<$>) :: Functor f => (a -> b) -> f a -> f b+f <$> a = fmap f a++-- | Replace the value.+(<$) :: Functor f => a -> f b -> f a+(<$) = (<$>) . const+ +-- | Sequence actions, discarding the value of the first argument.+(*>) :: Applicative f => f a -> f b -> f b+(*>) = liftA2 (const id)+ +-- | Sequence actions, discarding the value of the second argument.+(<*) :: Applicative f => 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 (flip ($))++-- | Lift a function to actions.+-- This function may be used as a value for `fmap` in a `Functor` instance.+liftA :: Applicative f => (a -> b) -> f a -> f b+liftA f a = pure f <*> a++-- | Lift a binary function to actions.+liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c+liftA2 f a b = f <$> a <*> b++-- | 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 = f <$> a <*> b <*> c++-- | One or none.+optional :: Alternative f => f a -> f (Maybe a)+optional v = Just <$> v <|> pure Nothing++-- | One or more.+some :: Alternative f => f a -> f [a]+some v = some_v+  where many_v = some_v <|> pure []+        some_v = (:) <$> v <*> many_v++-- | Zero or more.+many :: Alternative f => f a -> f [a]+many v = many_v+  where many_v = some_v <|> pure []+        some_v = (:) <$> v <*> many_v
Control/Arrow.hs view
@@ -1,2 +1,278 @@-module Control.Arrow (module X___) where-import "base" Control.Arrow as X___+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Arrow+-- Copyright   :  (c) Ross Paterson 2002+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- 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.+-- See these papers for the equations these combinators are expected to+-- satisfy.  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(..),++                (>>>), (<<<) -- reexported+        ) where++import Prelude hiding (id,(.))+import qualified Prelude++import Control.Monad+import Control.Monad.Fix+import Control.Category++infixr 5 <+>+infixr 3 ***+infixr 3 &&&+infixr 2 ++++infixr 2 |||+infixr 1 ^>>, >>^+infixr 1 ^<<, <<^++-- | The basic arrow class.+--+--   Minimal complete definition: 'arr' and 'first'.+--+--   The other combinators have sensible default definitions,+--   which may be overridden for efficiency.++class Category a => Arrow a where++        -- | 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)++        -- | A mirror image of 'first'.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        second :: a b c -> a (d,b) (d,c)+        second f = arr swap >>> first f >>> arr swap+                        where   swap ~(x,y) = (y,x)++        -- | 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 >>> second g++        -- | 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+"identity"+                arr id = id+"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.++instance Arrow (->) where+        arr f = f+        first f = f *** id+        second f = id *** f+--      (f *** g) ~(x,y) = (f x, g y)+--      sorry, although the above defn is fully H'98, nhc98 can't parse it.+        (***) f g ~(x,y) = (f x, g y)++-- | Kleisli arrows of a monad.++newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }++instance Monad m => Category (Kleisli m) where+        id = Kleisli return+        (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)++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++instance MonadPlus m => ArrowZero (Kleisli m) where+        zeroArrow = Kleisli (\_ -> mzero)++class ArrowZero a => ArrowPlus a where+        (<+>) :: a b c -> a b c -> a b c++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.+--   Any instance must define 'left'.  The other combinators have sensible+--   default definitions, which may be overridden for efficiency.++class Arrow a => ArrowChoice a where++        -- | 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)++        -- | A mirror image of 'left'.+        --+        --   The default definition may be overridden with a more efficient+        --   version if desired.+        right :: a b c -> a (Either d b) (Either d c)+        right f = arr mirror >>> left f >>> arr mirror+                        where   mirror (Left x) = Right x+                                mirror (Right y) = Left y++        -- | 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 >>> right g++        -- | 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)+ #-}++instance ArrowChoice (->) where+        left f = f +++ id+        right f = id +++ f+        f +++ g = (Left . f) ||| (Right . g)+        (|||) = either++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.++class Arrow a => ArrowApply a where+        app :: a (a b c, b) c++instance ArrowApply (->) where+        app (f,x) = f x++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 ArrowApply a => ArrowMonad a b = ArrowMonad (a () b)++instance ArrowApply a => Monad (ArrowMonad a) where+        return x = ArrowMonad (arr (\_ -> x))+        ArrowMonad m >>= f = ArrowMonad (m >>>+                        arr (\x -> let ArrowMonad h = f x in (h, ())) >>>+                        app)++-- | 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, even though the computation occurs only once.+--   It underlies the @rec@ value recursion construct in arrow notation.++class Arrow a => ArrowLoop a where+        loop :: a (b,d) (c,d) -> a b c++instance ArrowLoop (->) where+        loop f b = let (c,d) = f (b,d) in c++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 view
@@ -1,2 +1,52 @@-module Control.Category (module X___) where-import "base" Control.Category as X___+-----------------------------------------------------------------------------+-- |+-- 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++-- http://hackage.haskell.org/trac/ghc/ticket/1773++module Control.Category where++import Prelude hiding (id,(.))+import qualified Prelude++infixr 9 .+infixr 1 >>>, <<<++-- | A class for categories.+--   id and (.) must form a monoid.+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)+ #-}++instance Category (->) where+        id = Prelude.id+#ifndef __HADDOCK__+-- Haddock 1.x cannot parse this:+        (.) = (Prelude..)+#endif++-- | 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
Control/Concurrent.hs view
@@ -1,2 +1,636 @@-module Control.Concurrent (module X___) where-import "base" Control.Concurrent as X___+{-# OPTIONS_GHC -fno-warn-unused-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,+#ifdef __GLASGOW_HASKELL__+        myThreadId,+#endif++        forkIO,+#ifdef __GLASGOW_HASKELL__+        killThread,+        throwTo,+#endif++        -- * Scheduling++        -- $conc_scheduling     +        yield,                  -- :: IO ()++        -- ** Blocking++        -- $blocking++#ifdef __GLASGOW_HASKELL__+        -- ** Waiting+        threadDelay,            -- :: Int -> IO ()+        threadWaitRead,         -- :: Int -> IO ()+        threadWaitWrite,        -- :: Int -> IO ()+#endif++        -- * Communication abstractions++        module Control.Concurrent.MVar,+        module Control.Concurrent.Chan,+        module Control.Concurrent.QSem,+        module Control.Concurrent.QSemN,+        module Control.Concurrent.SampleVar,++        -- * Merging of streams+#ifndef __HUGS__+        mergeIO,                -- :: [a]   -> [a] -> IO [a]+        nmergeIO,               -- :: [[a]] -> IO [a]+#endif+        -- $merge++#ifdef __GLASGOW_HASKELL__+        -- * Bound Threads+        -- $boundthreads+        rtsSupportsBoundThreads,+        forkOS,+        isCurrentThreadBound,+        runInBoundThread,+        runInUnboundThread+#endif++        -- * 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+    ) where++import Prelude++import Control.Exception.Base as Exception++#ifdef __GLASGOW_HASKELL__+import GHC.Exception+import GHC.Conc         ( ThreadId(..), myThreadId, killThread, yield,+                          threadDelay, forkIO, childHandler )+import qualified GHC.Conc+import GHC.IOBase       ( IO(..) )+import GHC.IOBase       ( unsafeInterleaveIO )+import GHC.IOBase       ( newIORef, readIORef, writeIORef )+import GHC.Base++import System.Posix.Types ( Fd )+import Foreign.StablePtr+import Foreign.C.Types  ( CInt )+import Control.Monad    ( when )++#ifdef mingw32_HOST_OS+import Foreign.C+import System.IO+import GHC.Handle+#endif+#endif++#ifdef __HUGS__+import Hugs.ConcBase+#endif++import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Control.Concurrent.QSem+import Control.Concurrent.QSemN+import Control.Concurrent.SampleVar++#ifdef __HUGS__+type ThreadId = ()+#endif++{- $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.++Using Hugs, all I\/O operations and foreign calls will block all other+Haskell threads.+-}++#ifndef __HUGS__+max_buff_size :: Int+max_buff_size = 1++mergeIO :: [a] -> [a] -> IO [a]+nmergeIO :: [[a]] -> IO [a]++-- $merge+-- The 'mergeIO' and 'nmergeIO' functions fork one thread for each+-- input list that concurrently evaluates that list; the results are+-- merged into a single output list.  +--+-- Note: Hugs does not provide these functions, since they require+-- preemptive multitasking.++mergeIO ls rs+ = newEmptyMVar                >>= \ tail_node ->+   newMVar tail_node           >>= \ tail_list ->+   newQSem max_buff_size       >>= \ e ->+   newMVar 2                   >>= \ branches_running ->+   let+    buff = (tail_list,e)+   in+    forkIO (suckIO branches_running buff ls) >>+    forkIO (suckIO branches_running buff rs) >>+    takeMVar tail_node  >>= \ val ->+    signalQSem e        >>+    return val++type Buffer a+ = (MVar (MVar [a]), QSem)++suckIO :: MVar Int -> Buffer a -> [a] -> IO ()++suckIO branches_running buff@(tail_list,e) vs+ = case vs of+        [] -> takeMVar branches_running >>= \ val ->+              if val == 1 then+                 takeMVar tail_list     >>= \ node ->+                 putMVar node []        >>+                 putMVar tail_list node+              else+                 putMVar branches_running (val-1)+        (x:xs) ->+                waitQSem e                       >>+                takeMVar tail_list               >>= \ node ->+                newEmptyMVar                     >>= \ next_node ->+                unsafeInterleaveIO (+                        takeMVar next_node  >>= \ y ->+                        signalQSem e        >>+                        return y)                >>= \ next_node_val ->+                putMVar node (x:next_node_val)   >>+                putMVar tail_list next_node      >>+                suckIO branches_running buff xs++nmergeIO lss+ = let+    len = length lss+   in+    newEmptyMVar          >>= \ tail_node ->+    newMVar tail_node     >>= \ tail_list ->+    newQSem max_buff_size >>= \ e ->+    newMVar len           >>= \ branches_running ->+    let+     buff = (tail_list,e)+    in+    mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>+    takeMVar tail_node  >>= \ val ->+    signalQSem e        >>+    return val+  where+    mapIO f xs = sequence (map f xs)+#endif /* __HUGS__ */++#ifdef __GLASGOW_HASKELL__+-- ---------------------------------------------------------------------------+-- 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 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.blocked+        let+            -- async exceptions are blocked in the child if they are blocked+            -- in the parent, as for forkIO (see #1048). forkOS_createThread+            -- creates a thread with exceptions blocked by default.+            action1 | b = action0+                    | otherwise = unblock action0++            action_plus = Exception.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++-- | 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#, not (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+                resultOrException <-+                    bracket (newStablePtr action_plus)+                            freeStablePtr+                            (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)+                case resultOrException of+                    Left exception -> Exception.throw (exception :: SomeException)+                    Right result -> return result+    | 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 it's main thread to be bound and makes /heavy/ use of concurrency+(e.g. a web server), might want to wrap it's @main@ action in+@runInUnboundThread@.+-}+runInUnboundThread :: IO a -> IO a++runInUnboundThread action = do+    bound <- isCurrentThreadBound+    if bound+        then do+            mv <- newEmptyMVar+            forkIO (Exception.try action >>= putMVar mv)+            takeMVar mv >>= \ei -> case ei of+                Left exception -> Exception.throw (exception :: SomeException)+                Right result -> return result+        else action++#endif /* __GLASGOW_HASKELL__ */++#ifdef __GLASGOW_HASKELL__+-- ---------------------------------------------------------------------------+-- threadWaitRead/threadWaitWrite++-- | Block the current thread until data is available to read on the+-- given file descriptor (GHC only).+threadWaitRead :: Fd -> IO ()+threadWaitRead fd+#ifdef 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 0)+  | 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.+                  _ -> error "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).+threadWaitWrite :: Fd -> IO ()+threadWaitWrite fd+#ifdef mingw32_HOST_OS+  | threaded  = withThread (waitFd fd 1)+  | otherwise = error "threadWaitWrite requires -threaded on Windows"+#else+  = GHC.Conc.threadWaitWrite fd+#endif++#ifdef mingw32_HOST_OS+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool++withThread :: IO a -> IO a+withThread io = do+  m <- newEmptyMVar+  forkIO $ try io >>= putMVar m+  x <- takeMVar m+  case x of+    Right a -> return a+    Left e  -> throwIO (e :: IOException)++waitFd :: Fd -> CInt -> IO ()+waitFd fd write = do+   throwErrnoIfMinus1 "fdReady" $+        fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0+   return ()++iNFINITE :: CInt+iNFINITE = 0xFFFFFFFF -- urgh++foreign import ccall safe "fdReady"+  fdReady :: CInt -> CInt -> CInt -> CInt -> 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 reqwests+      are managed by a single thread (the /IO manager thread/) using+      @select@.++      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+>     forkIO (io `finally` putMVar mvar ())+>     return mvar++      Note that we use 'finally' from the+      "Control.Exception" module 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)+>        forkIO (io `finally` 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 :-)+-}+#endif /* __GLASGOW_HASKELL__ */
Control/Concurrent/Chan.hs view
@@ -1,2 +1,132 @@-module Control.Concurrent.Chan (module X___) where-import "base" Control.Concurrent.Chan as X___+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++module Control.Concurrent.Chan+  ( +          -- * The 'Chan' type+        Chan,                   -- abstract++          -- * Operations+        newChan,                -- :: IO (Chan a)+        writeChan,              -- :: Chan a -> a -> IO ()+        readChan,               -- :: Chan a -> IO a+        dupChan,                -- :: Chan a -> IO (Chan a)+        unGetChan,              -- :: Chan a -> a -> IO ()+        isEmptyChan,            -- :: Chan a -> IO Bool++          -- * Stream interface+        getChanContents,        -- :: Chan a -> IO [a]+        writeList2Chan,         -- :: Chan a -> [a] -> IO ()+   ) where++import Prelude++import System.IO.Unsafe         ( unsafeInterleaveIO )+import Control.Concurrent.MVar+import Data.Typeable++#include "Typeable.h"++-- 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 (MVar (Stream a))+        (MVar (Stream a))++INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")++type Stream a = MVar (ChItem a)++data ChItem a = ChItem a (Stream a)++-- 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+  modifyMVar_ writeVar $ \old_hole -> do+    putMVar old_hole (ChItem val new_hole)+    return new_hole++-- |Read the next value from the 'Chan'.+readChan :: Chan a -> IO a+readChan (Chan readVar _) = do+  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.+dupChan :: Chan a -> IO (Chan a)+dupChan (Chan _ writeVar) = do+   hole       <- readMVar writeVar+   newReadVar <- newMVar hole+   return (Chan newReadVar writeVar)++-- |Put a data item back onto a channel, where it will be the next item read.+unGetChan :: Chan a -> a -> IO ()+unGetChan (Chan readVar _) val = do+   new_read_end <- newEmptyMVar+   modifyMVar_ readVar $ \read_end -> do+     putMVar new_read_end (ChItem val read_end)+     return new_read_end++-- |Returns 'True' if the supplied 'Chan' is empty.+isEmptyChan :: Chan a -> IO Bool+isEmptyChan (Chan readVar writeVar) = do+   withMVar readVar $ \r -> do+     w <- readMVar writeVar+     let eq = r == w+     eq `seq` return eq++-- 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 view
@@ -1,2 +1,116 @@-module Control.Concurrent.MVar (module X___) where-import "base" Control.Concurrent.MVar as X___+-----------------------------------------------------------------------------+-- |+-- 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)+--+-- Synchronising variables+--+-----------------------------------------------------------------------------++module Control.Concurrent.MVar+        (+          -- * @MVar@s+          MVar          -- abstract+        , newEmptyMVar  -- :: IO (MVar a)+        , newMVar       -- :: a -> IO (MVar a)+        , takeMVar      -- :: MVar a -> IO a+        , putMVar       -- :: MVar a -> a -> IO ()+        , readMVar      -- :: MVar a -> IO a+        , swapMVar      -- :: MVar a -> a -> IO a+        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)+        , tryPutMVar    -- :: MVar a -> a -> IO Bool+        , isEmptyMVar   -- :: MVar a -> IO Bool+        , withMVar      -- :: MVar a -> (a -> IO b) -> IO b+        , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()+        , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b+#ifndef __HUGS__+        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()+#endif+    ) where++#ifdef __HUGS__+import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,+                  tryTakeMVar, tryPutMVar, isEmptyMVar,+                )+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,+                  tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer+                )+#endif++import Prelude+import Control.Exception.Base++{-|+  This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value+  from the 'MVar', puts it back, and also returns it.+-}+readMVar :: MVar a -> IO a+readMVar m =+  block $ do+    a <- takeMVar m+    putMVar m a+    return a++{-|+  Take a value from an 'MVar', put a new value into the 'MVar' and+  return the value taken. Note that there is a race condition whereby+  another process can put something in the 'MVar' after the take+  happens but before the put does.+-}+swapMVar :: MVar a -> a -> IO a+swapMVar mvar new =+  block $ do+    old <- takeMVar mvar+    putMVar mvar new+    return old++{-|+  'withMVar' is a 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").+-}+{-# 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 =+  block $ do+    a <- takeMVar m+    b <- unblock (io a) `onException` putMVar m a+    putMVar m a+    return b++{-|+  A 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.+-}+{-# INLINE modifyMVar_ #-}+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVar_ m io =+  block $ do+    a  <- takeMVar m+    a' <- unblock (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 =+  block $ do+    a      <- takeMVar m+    (a',b) <- unblock (io a) `onException` putMVar m a+    putMVar m a'+    return b
Control/Concurrent/QSem.hs view
@@ -1,2 +1,77 @@-module Control.Concurrent.QSem (module X___) where-import "base" Control.Concurrent.QSem as X___+-----------------------------------------------------------------------------+-- |+-- 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 Prelude+import Control.Concurrent.MVar+import Data.Typeable++#include "Typeable.h"++-- General semaphores are also implemented readily in terms of shared+-- @MVar@s, only have to catch the case when the semaphore is tried+-- waited on when it is empty (==0). Implement this in the same way as+-- shared variables are implemented - maintaining a list of @MVar@s+-- representing threads currently waiting. The counter is a shared+-- variable, ensuring the mutual exclusion on its access.++-- |A 'QSem' is a simple quantity semaphore, in which the available+-- \"quantity\" is always dealt with in units of one.+newtype QSem = QSem (MVar (Int, [MVar ()]))++INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")++-- |Build a new 'QSem'+newQSem :: Int -> IO QSem+newQSem initial = do+   sem <- newMVar (initial, [])+   return (QSem sem)++-- |Wait for a unit to become available+waitQSem :: QSem -> IO ()+waitQSem (QSem sem) = do+   (avail,blocked) <- takeMVar sem  -- gain ex. access+   if avail > 0 then+     putMVar sem (avail-1,[])+    else do+     block <- newEmptyMVar+      {-+        Stuff the reader at the back of the queue,+        so as to preserve waiting order. A signalling+        process then only have to pick the MVar at the+        front of the blocked list.++        The version of waitQSem given in the paper could+        lead to starvation.+      -}+     putMVar sem (0, blocked++[block])+     takeMVar block++-- |Signal that a unit of the 'QSem' is available+signalQSem :: QSem -> IO ()+signalQSem (QSem sem) = do+   (avail,blocked) <- takeMVar sem+   case blocked of+     [] -> putMVar sem (avail+1,[])++     (block:blocked') -> do+           putMVar sem (0,blocked')+           putMVar block ()
Control/Concurrent/QSemN.hs view
@@ -1,2 +1,70 @@-module Control.Concurrent.QSemN (module X___) where-import "base" Control.Concurrent.QSemN as X___+-----------------------------------------------------------------------------+-- |+-- 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 Prelude++import Control.Concurrent.MVar+import Data.Typeable++#include "Typeable.h"++-- |A 'QSemN' is a quantity semaphore, in which the available+-- \"quantity\" may be signalled or waited for in arbitrary amounts.+newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))++INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")++-- |Build a new 'QSemN' with a supplied initial quantity.+newQSemN :: Int -> IO QSemN +newQSemN initial = do+   sem <- newMVar (initial, [])+   return (QSemN sem)++-- |Wait for the specified quantity to become available+waitQSemN :: QSemN -> Int -> IO ()+waitQSemN (QSemN sem) sz = do+  (avail,blocked) <- takeMVar sem   -- gain ex. access+  if (avail - sz) >= 0 then+       -- discharging 'sz' still leaves the semaphore+       -- in an 'unblocked' state.+     putMVar sem (avail-sz,blocked)+   else do+     block <- newEmptyMVar+     putMVar sem (avail, blocked++[(sz,block)])+     takeMVar block++-- |Signal that a given quantity is now available from the 'QSemN'.+signalQSemN :: QSemN -> Int  -> IO ()+signalQSemN (QSemN sem) n = do+   (avail,blocked)   <- takeMVar sem+   (avail',blocked') <- free (avail+n) blocked+   putMVar sem (avail',blocked')+ where+   free avail []    = return (avail,[])+   free avail ((req,block):blocked)+     | avail >= req = do+        putMVar block ()+        free (avail-req) blocked+     | otherwise    = do+        (avail',blocked') <- free avail blocked+        return (avail',(req,block):blocked')
Control/Concurrent/SampleVar.hs view
@@ -1,2 +1,117 @@-module Control.Concurrent.SampleVar (module X___) where-import "base" Control.Concurrent.SampleVar as X___+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.SampleVar+-- 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)+--+-- Sample variables+--+-----------------------------------------------------------------------------++module Control.Concurrent.SampleVar+       (+         -- * Sample Variables+         SampleVar,         -- :: type _ =+ +         newEmptySampleVar, -- :: IO (SampleVar a)+         newSampleVar,      -- :: a -> IO (SampleVar a)+         emptySampleVar,    -- :: SampleVar a -> IO ()+         readSampleVar,     -- :: SampleVar a -> IO a+         writeSampleVar,    -- :: SampleVar a -> a -> IO ()+         isEmptySampleVar,  -- :: SampleVar a -> IO Bool++       ) where++import Prelude++import Control.Concurrent.MVar++-- |+-- Sample variables are slightly different from a normal 'MVar':+-- +--  * Reading an empty 'SampleVar' causes the reader to block.+--    (same as 'takeMVar' on empty 'MVar')+-- +--  * Reading a filled 'SampleVar' empties it and returns value.+--    (same as 'takeMVar')+-- +--  * Writing to an empty 'SampleVar' fills it with a value, and+--    potentially, wakes up a blocked reader (same as for 'putMVar' on+--    empty 'MVar').+--+--  * Writing to a filled 'SampleVar' overwrites the current value.+--    (different from 'putMVar' on full 'MVar'.)++type SampleVar a+ = MVar (Int,           -- 1  == full+                        -- 0  == empty+                        -- <0 no of readers blocked+          MVar a)++-- |Build a new, empty, 'SampleVar'+newEmptySampleVar :: IO (SampleVar a)+newEmptySampleVar = do+   v <- newEmptyMVar+   newMVar (0,v)++-- |Build a 'SampleVar' with an initial value.+newSampleVar :: a -> IO (SampleVar a)+newSampleVar a = do+   v <- newEmptyMVar+   putMVar v a+   newMVar (1,v)++-- |If the SampleVar is full, leave it empty.  Otherwise, do nothing.+emptySampleVar :: SampleVar a -> IO ()+emptySampleVar v = do+   (readers, var) <- takeMVar v+   if readers > 0 then do+     takeMVar var+     putMVar v (0,var)+    else+     putMVar v (readers,var)++-- |Wait for a value to become available, then take it and return.+readSampleVar :: SampleVar a -> IO a+readSampleVar svar = do+--+-- filled => make empty and grab sample+-- not filled => try to grab value, empty when read val.+--+   (readers,val) <- takeMVar svar+   putMVar svar (readers-1,val)+   takeMVar val++-- |Write a value into the 'SampleVar', overwriting any previous value that+-- was there.+writeSampleVar :: SampleVar a -> a -> IO ()+writeSampleVar svar v = do+--+-- filled => overwrite+-- not filled => fill, write val+--+   (readers,val) <- takeMVar svar+   case readers of+     1 -> +       swapMVar val v >> +       putMVar svar (1,val)+     _ -> +       putMVar val v >> +       putMVar svar (min 1 (readers+1), val)++-- | Returns 'True' if the 'SampleVar' is currently empty.+--+-- Note that this function is only useful if you know that no other+-- threads can be modifying the state of the 'SampleVar', because+-- otherwise the state of the 'SampleVar' may have changed by the time+-- you see the result of 'isEmptySampleVar'.+--+isEmptySampleVar :: SampleVar a -> IO Bool+isEmptySampleVar svar = do+   (readers, _) <- readMVar svar+   return (readers == 0)+
Control/Exception.hs view
@@ -1,2 +1,232 @@-module Control.Exception (module Control.OldException) where-import Control.OldException+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- 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/.+--+-----------------------------------------------------------------------------++module Control.Exception (++        -- * The Exception type+#ifdef __HUGS__+        SomeException,+#else+        SomeException(..),+#endif+        Exception(..),          -- class+        IOException,            -- instance Eq, Ord, Show, Typeable, Exception+        ArithException(..),     -- instance Eq, Ord, Show, Typeable, Exception+        ArrayException(..),     -- instance Eq, Ord, Show, Typeable, Exception+        AssertionFailed(..),+        AsyncException(..),     -- instance Eq, Ord, Show, Typeable, Exception++#if __GLASGOW_HASKELL__ || __HUGS__+        NonTermination(..),+        NestedAtomically(..),+#endif+#ifdef __NHC__+        System.ExitCode(),	-- instance Exception+#endif++        BlockedOnDeadMVar(..),+        BlockedIndefinitely(..),+        Deadlock(..),+        NoMethodError(..),+        PatternMatchFail(..),+        RecConError(..),+        RecSelError(..),+        RecUpdError(..),+        ErrorCall(..),++        -- * Throwing exceptions+        throwIO,        -- :: Exception -> IO a+        throw,          -- :: Exception -> a+        ioError,        -- :: IOError -> IO a+#ifdef __GLASGOW_HASKELL__+        throwTo,        -- :: ThreadId -> Exception -> a+#endif++        -- * Catching Exceptions++        -- |There are several functions for catching and examining+        -- exceptions; all of them may only be used from within the+        -- 'IO' monad.++        -- ** The @catch@ functions+        catch,     -- :: IO a -> (Exception -> IO a) -> IO a+        catches, Handler(..),+        catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a++        -- ** The @handle@ functions+        handle,    -- :: (Exception -> IO a) -> IO a -> IO a+        handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a++        -- ** The @try@ functions+        try,       -- :: IO a -> IO (Either Exception a)+        tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)+        onException,++        -- ** The @evaluate@ function+        evaluate,  -- :: a -> IO a++        -- ** The @mapException@ function+        mapException,           -- :: (Exception -> Exception) -> a -> a++        -- * Asynchronous Exceptions++        -- $async++        -- ** Asynchronous exception control++        -- |The following two functions allow a thread to control delivery of+        -- asynchronous exceptions during a critical region.++        block,          -- :: IO a -> IO a+        unblock,        -- :: IO a -> IO a+        blocked,        -- :: IO Bool++        -- *** Applying @block@ to an exception handler++        -- $block_handler++        -- *** Interruptible operations++        -- $interruptible++        -- * Assertions++        assert,         -- :: Bool -> a -> a++        -- * Utilities++        bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()+        bracket_,       -- :: IO a -> IO b -> IO c -> IO ()+        bracketOnError,++        finally,        -- :: IO a -> IO b -> IO a+  ) where++import Control.Exception.Base++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import Data.Maybe+#else+import Prelude hiding (catch)+#endif++#ifdef __NHC__+import System (ExitCode())+#endif++data Handler a = forall e . Exception e => Handler (e -> IO a)++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++-- -----------------------------------------------------------------------------+-- Asynchronous exceptions++{- $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 'throwDynTo' and '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 'block' 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 blocked 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++>      block (+>           catch (unblock (...))+>                      (\e -> handler)+>      )++If you need to unblock asynchronous exceptions again in the exception+handler, just use 'unblock' as normal.++Note that 'try' and friends /do not/ have a similar default, because+there is no exception handler in this case.  If you want to use 'try'+in an asynchronous-exception-safe way, you will need to use+'block'.+-}++{- $interruptible++Some operations are /interruptible/, which means that they can receive+asynchronous exceptions even in the scope of a 'block'.  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++>      block (+>         a <- takeMVar m+>         catch (unblock (...))+>               (\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'.+-}
+ Control/Exception/Base.hs view
@@ -0,0 +1,688 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "Typeable.h"++-----------------------------------------------------------------------------+-- |+-- 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+#ifdef __HUGS__+        SomeException,+#else+        SomeException(..),+#endif+        Exception(..),+        IOException,+        ArithException(..),+        ArrayException(..),+        AssertionFailed(..),+        AsyncException(..),++#if __GLASGOW_HASKELL__ || __HUGS__+        NonTermination(..),+        NestedAtomically(..),+#endif++        BlockedOnDeadMVar(..),+        BlockedIndefinitely(..),+        Deadlock(..),+        NoMethodError(..),+        PatternMatchFail(..),+        RecConError(..),+        RecSelError(..),+        RecUpdError(..),+        ErrorCall(..),++        -- * Throwing exceptions+        throwIO,+        throw,+        ioError,+#ifdef __GLASGOW_HASKELL__+        throwTo,+#endif++        -- * 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++        block,+        unblock,+        blocked,++        -- * Assertions++        assert,++        -- * Utilities++        bracket,+        bracket_,+        bracketOnError,++        finally,++#ifdef __GLASGOW_HASKELL__+        -- * Calls for GHC runtime+        recSelError, recConError, irrefutPatError, runtimeError,+        nonExhaustiveGuardsError, patError, noMethodBindingError,+        nonTermination, nestedAtomically,+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import GHC.Show+import GHC.IOBase+import GHC.Exception hiding ( Exception )+import GHC.Conc+#endif++#ifdef __HUGS__+import Prelude hiding (catch)+import Hugs.Prelude (ExitCode(..))+import Hugs.IOExts (unsafePerformIO)+import Hugs.Exception (SomeException(DynamicException, IOException,+                                     ArithException, ArrayException, ExitException),+                       evaluate, IOException, ArithException, ArrayException)+import qualified Hugs.Exception+#endif++import Data.Dynamic+import Data.Either+import Data.Maybe++#ifdef __NHC__+import qualified System.IO.Error as H'98 (catch)+import System.IO.Error (ioError)+import IO              (bracket)+import DIOError         -- defn of IOError type+import System          (ExitCode())+import System.IO.Unsafe (unsafePerformIO)+import Unsafe.Coerce    (unsafeCoerce)++-- minimum needed for nhc98 to pretend it has Exceptions++{-+data Exception   = IOException    IOException+                 | ArithException ArithException+                 | ArrayException ArrayException+                 | AsyncException AsyncException+                 | ExitException  ExitCode+                 deriving Show+-}+class ({-Typeable e,-} Show e) => Exception e where+    toException   :: e -> SomeException+    fromException :: SomeException -> Maybe e++data SomeException = forall e . Exception e => SomeException e++INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")++instance Show SomeException where+    showsPrec p (SomeException e) = showsPrec p e+instance Exception SomeException where+    toException se = se+    fromException = Just++type IOException = IOError+instance Exception IOError where+    toException                     = SomeException+    fromException (SomeException e) = Just (unsafeCoerce e)++instance Exception ExitCode where+    toException                     = SomeException+    fromException (SomeException e) = Just (unsafeCoerce e)++data ArithException+data ArrayException+data AsyncException+data AssertionFailed+data PatternMatchFail+data NoMethodError+data Deadlock+data BlockedOnDeadMVar+data BlockedIndefinitely+data ErrorCall+data RecConError+data RecSelError+data RecUpdError+instance Show ArithException+instance Show ArrayException+instance Show AsyncException+instance Show AssertionFailed+instance Show PatternMatchFail+instance Show NoMethodError+instance Show Deadlock+instance Show BlockedOnDeadMVar+instance Show BlockedIndefinitely+instance Show ErrorCall+instance Show RecConError+instance Show RecSelError+instance Show RecUpdError++catch   :: Exception e+        => IO a         -- ^ The computation to run+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised+        -> IO a+catch io h = H'98.catch  io  (h . fromJust . fromException . toException)++throwIO  :: Exception e => e -> IO a+throwIO   = ioError . fromJust . fromException . toException++throw    :: Exception e => e -> a+throw     = unsafePerformIO . throwIO++evaluate :: a -> IO a+evaluate x = x `seq` return x++assert :: Bool -> a -> a+assert True  x = x+assert False _ = throw (toException (UserError "" "Assertion failed"))++#endif++#ifdef __HUGS__+class (Typeable e, Show e) => Exception e where+    toException   :: e -> SomeException+    fromException :: SomeException -> Maybe e++    toException e = DynamicException (toDyn e) (flip showsPrec e)+    fromException (DynamicException dyn _) = fromDynamic dyn+    fromException _ = Nothing++INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")+INSTANCE_TYPEABLE0(IOException,iOExceptionTc,"IOException")+INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")+INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")+INSTANCE_TYPEABLE0(ExitCode,exitCodeTc,"ExitCode")+INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall")+INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")+INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")+INSTANCE_TYPEABLE0(BlockedOnDeadMVar,blockedOnDeadMVarTc,"BlockedOnDeadMVar")+INSTANCE_TYPEABLE0(BlockedIndefinitely,blockedIndefinitelyTc,"BlockedIndefinitely")+INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")++instance Exception SomeException where+    toException se = se+    fromException = Just++instance Exception IOException where+    toException = IOException+    fromException (IOException e) = Just e+    fromException _ = Nothing++instance Exception ArrayException where+    toException = ArrayException+    fromException (ArrayException e) = Just e+    fromException _ = Nothing++instance Exception ArithException where+    toException = ArithException+    fromException (ArithException e) = Just e+    fromException _ = Nothing++instance Exception ExitCode where+    toException = ExitException+    fromException (ExitException e) = Just e+    fromException _ = Nothing++data ErrorCall = ErrorCall String++instance Show ErrorCall where+    showsPrec _ (ErrorCall err) = showString err++instance Exception ErrorCall where+    toException (ErrorCall s) = Hugs.Exception.ErrorCall s+    fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s)+    fromException _ = Nothing++data BlockedOnDeadMVar = BlockedOnDeadMVar+data BlockedIndefinitely = BlockedIndefinitely+data Deadlock = Deadlock+data AssertionFailed = AssertionFailed String+data AsyncException+  = StackOverflow+  | HeapOverflow+  | ThreadKilled+  | UserInterrupt+  deriving (Eq, Ord)++instance Show BlockedOnDeadMVar where+    showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"++instance Show BlockedIndefinitely where+    showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"++instance Show Deadlock where+    showsPrec _ Deadlock = showString "<<deadlock>>"++instance Show AssertionFailed where+    showsPrec _ (AssertionFailed err) = showString err++instance Show AsyncException where+    showsPrec _ StackOverflow   = showString "stack overflow"+    showsPrec _ HeapOverflow    = showString "heap overflow"+    showsPrec _ ThreadKilled    = showString "thread killed"+    showsPrec _ UserInterrupt   = showString "user interrupt"++instance Exception BlockedOnDeadMVar+instance Exception BlockedIndefinitely+instance Exception Deadlock+instance Exception AssertionFailed+instance Exception AsyncException++throw :: Exception e => e -> a+throw e = Hugs.Exception.throw (toException e)++throwIO :: Exception e => e -> IO a+throwIO e = Hugs.Exception.throwIO (toException e)+#endif++#ifndef __GLASGOW_HASKELL__+-- Dummy definitions for implementations lacking asynchonous exceptions++block   :: IO a -> IO a+block    = id+unblock :: IO a -> IO a+unblock  = id+blocked :: IO Bool+blocked  = return False+#endif++-----------------------------------------------------------------------------+-- Catching exceptions++-- |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 (openFile f ReadMode)+-- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))+--+-- For catching exceptions in pure (non-'IO') expressions, see the+-- function 'evaluate'.+--+-- Note that due to Haskell\'s unspecified evaluation order, an+-- expression may return one of several possible exceptions: consider+-- the expression @error \"urk\" + 1 \`div\` 0@.  Does+-- 'catch' execute the handler passing+-- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?+--+-- The answer is \"either\": 'catch' makes a+-- non-deterministic choice about which exception to catch.  If you+-- call it again, you might get a different exception back.  This is+-- ok, because 'catch' is an 'IO' computation.+--+-- Note that 'catch' catches all types of exceptions, and is generally+-- used for \"cleaning up\" before passing on the exception using+-- 'throwIO'.  It is not good practice to discard the exception and+-- continue, without first checking the type of the exception (it+-- might be a 'ThreadKilled', for example).  In this case it is usually better+-- to use 'catchJust' and select the kinds of exceptions to catch.+--+-- Also note that the "Prelude" also exports a function called+-- 'Prelude.catch' with a similar type to 'Control.Exception.catch',+-- except that the "Prelude" version only catches the IO and user+-- families of exceptions (as required by Haskell 98).+--+-- We recommend either hiding the "Prelude" version of 'Prelude.catch'+-- when importing "Control.Exception":+--+-- > import Prelude hiding (catch)+--+-- or importing "Control.Exception" qualified, to avoid name-clashes:+--+-- > import qualified Control.Exception as C+--+-- and then using @C.catch@+--+#ifndef __NHC__+catch   :: Exception e+        => IO a         -- ^ The computation to run+        -> (e -> IO a)  -- ^ Handler to invoke if an exception is raised+        -> IO a+#if __GLASGOW_HASKELL__+catch = GHC.IOBase.catchException+#elif __HUGS__+catch m h = Hugs.Exception.catchException m h'+  where h' e = case fromException e of+            Just e' -> h e'+            Nothing -> throwIO e+#endif+#endif++-- | 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.+--+-- >   result <- catchJust errorCalls thing_to_try handler+--+-- Any other exceptions which are not matched by the predicate+-- are re-raised, and may be caught by an enclosing+-- 'catch' or 'catchJust'.+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 -> throw 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 (\e -> 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 -> throw (f x)))++-----------------------------------------------------------------------------+-- 'try' and variations.++-- | Similar to 'catch', but returns an 'Either' result which is+-- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an+-- exception was raised and its value is @e@.+--+-- >  try a = catch (Right `liftM` a) (return . Left)+--+-- Note: as with 'catch', it is only polite to use this variant if you intend+-- to re-throw the exception after performing whatever cleanup is needed.+-- Otherwise, 'tryJust' is generally considered to be better.+--+-- Also note that "System.IO.Error" also exports a function called+-- 'System.IO.Error.try' with a similar type to 'Control.Exception.try',+-- except that it catches only the IO and user families of exceptions+-- (as required by the Haskell 98 @IO@ module).++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 -> throw e+                        Just b  -> return (Left b)++onException :: IO a -> IO b -> IO a+onException io what = io `catch` \e -> do what+                                          throw (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)+-- >   (\handle -> 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+--+#ifndef __NHC__+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 =+  block (do+    a <- before+    r <- unblock (thing a) `onException` after a+    after a+    return r+ )+#endif++-- | 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 =+  block (do+    r <- unblock 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 =+  block (do+    a <- before+    unblock (thing a) `onException` after a+  )++#if !(__GLASGOW_HASKELL__ || __NHC__)+assert :: Bool -> a -> a+assert True x = x+assert False _ = throw (AssertionFailed "")+#endif++-----++#if __GLASGOW_HASKELL__ || __HUGS__+data PatternMatchFail = PatternMatchFail String+INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")++instance Show PatternMatchFail where+    showsPrec _ (PatternMatchFail err) = showString err++#ifdef __HUGS__+instance Exception PatternMatchFail where+    toException (PatternMatchFail err) = Hugs.Exception.PatternMatchFail err+    fromException (Hugs.Exception.PatternMatchFail err) = Just (PatternMatchFail err)+    fromException _ = Nothing+#else+instance Exception PatternMatchFail+#endif++-----++data RecSelError = RecSelError String+INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")++instance Show RecSelError where+    showsPrec _ (RecSelError err) = showString err++#ifdef __HUGS__+instance Exception RecSelError where+    toException (RecSelError err) = Hugs.Exception.RecSelError err+    fromException (Hugs.Exception.RecSelError err) = Just (RecSelError err)+    fromException _ = Nothing+#else+instance Exception RecSelError+#endif++-----++data RecConError = RecConError String+INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")++instance Show RecConError where+    showsPrec _ (RecConError err) = showString err++#ifdef __HUGS__+instance Exception RecConError where+    toException (RecConError err) = Hugs.Exception.RecConError err+    fromException (Hugs.Exception.RecConError err) = Just (RecConError err)+    fromException _ = Nothing+#else+instance Exception RecConError+#endif++-----++data RecUpdError = RecUpdError String+INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")++instance Show RecUpdError where+    showsPrec _ (RecUpdError err) = showString err++#ifdef __HUGS__+instance Exception RecUpdError where+    toException (RecUpdError err) = Hugs.Exception.RecUpdError err+    fromException (Hugs.Exception.RecUpdError err) = Just (RecUpdError err)+    fromException _ = Nothing+#else+instance Exception RecUpdError+#endif++-----++data NoMethodError = NoMethodError String+INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")++instance Show NoMethodError where+    showsPrec _ (NoMethodError err) = showString err++#ifdef __HUGS__+instance Exception NoMethodError where+    toException (NoMethodError err) = Hugs.Exception.NoMethodError err+    fromException (Hugs.Exception.NoMethodError err) = Just (NoMethodError err)+    fromException _ = Nothing+#else+instance Exception NoMethodError+#endif++-----++data NonTermination = NonTermination+INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")++instance Show NonTermination where+    showsPrec _ NonTermination = showString "<<loop>>"++#ifdef __HUGS__+instance Exception NonTermination where+    toException NonTermination = Hugs.Exception.NonTermination+    fromException Hugs.Exception.NonTermination = Just NonTermination+    fromException _ = Nothing+#else+instance Exception NonTermination+#endif++-----++data NestedAtomically = NestedAtomically+INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")++instance Show NestedAtomically where+    showsPrec _ NestedAtomically = showString "Control.Concurrent.STM.atomically was nested"++instance Exception NestedAtomically++-----++instance Exception Dynamic++#endif /* __GLASGOW_HASKELL__ || __HUGS__ */++#ifdef __GLASGOW_HASKELL__+recSelError, recConError, irrefutPatError, runtimeError,+             nonExhaustiveGuardsError, patError, noMethodBindingError+        :: Addr# -> a   -- All take a UTF8-encoded C string++recSelError              s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately+runtimeError             s = error (unpackCStringUtf8# s)               -- No location info unfortunately++nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))+irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))+recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))+noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))+patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))++-- GHC's RTS calls this+nonTermination :: SomeException+nonTermination = toException NonTermination++-- GHC's RTS calls this+nestedAtomically :: SomeException+nestedAtomically = toException NestedAtomically+#endif
Control/Monad.hs view
@@ -1,2 +1,334 @@-module Control.Monad (module X___) where-import "base" Control.Monad as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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(fmap)+    , Monad((>>=), (>>), return, fail)++    , MonadPlus (   -- class context: Monad+          mzero     -- :: (MonadPlus m) => m a+        , mplus     -- :: (MonadPlus m) => m a -> m a -> m a+        )+    -- * Functions++    -- ** Naming conventions+    -- $naming++    -- ** Basic functions from the "Prelude"++    , mapM          -- :: (Monad m) => (a -> m b) -> [a] -> m [b]+    , mapM_         -- :: (Monad m) => (a -> m b) -> [a] -> m ()+    , forM          -- :: (Monad m) => [a] -> (a -> m b) -> m [b]+    , forM_         -- :: (Monad m) => [a] -> (a -> m b) -> m ()+    , sequence      -- :: (Monad m) => [m a] -> m [a]+    , sequence_     -- :: (Monad m) => [m a] -> m ()+    , (=<<)         -- :: (Monad m) => (a -> m b) -> m a -> m b+    , (>=>)         -- :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c)+    , (<=<)         -- :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)+    , forever       -- :: (Monad m) => m a -> m b++    -- ** Generalisations of list functions++    , join          -- :: (Monad m) => m (m a) -> m a+    , msum          -- :: (MonadPlus m) => [m a] -> m a+    , filterM       -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+    , mapAndUnzipM  -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+    , zipWithM      -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+    , zipWithM_     -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+    , foldM         -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +    , foldM_        -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()+    , replicateM    -- :: (Monad m) => Int -> m a -> m [a]+    , replicateM_   -- :: (Monad m) => Int -> m a -> m ()++    -- ** Conditional execution of monadic expressions++    , guard         -- :: (MonadPlus m) => Bool -> m ()+    , when          -- :: (Monad m) => Bool -> m () -> m ()+    , unless        -- :: (Monad m) => Bool -> m () -> m ()++    -- ** Monadic lifting operators++    , liftM         -- :: (Monad m) => (a -> b) -> (m a -> m b)+    , liftM2        -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)+    , liftM3        -- :: ...+    , liftM4        -- :: ...+    , liftM5        -- :: ...++    , ap            -- :: (Monad m) => m (a -> b) -> m a -> m b++    ) where++import Data.Maybe++#ifdef __GLASGOW_HASKELL__+import GHC.List+import GHC.Base+#endif++#ifdef __GLASGOW_HASKELL__+infixr 1 =<<++-- -----------------------------------------------------------------------------+-- Prelude monad functions++-- | 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++-- | Evaluate each action in the sequence from left to right,+-- and collect the results.+sequence       :: Monad m => [m a] -> m [a] +{-# INLINE sequence #-}+sequence ms = foldr k (return []) ms+            where+              k m m' = do { x <- m; xs <- m'; return (x:xs) }++-- | Evaluate each action in the sequence from left to right,+-- and ignore the results.+sequence_        :: Monad m => [m a] -> m () +{-# INLINE sequence_ #-}+sequence_ ms     =  foldr (>>) (return ()) ms++-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@.+mapM            :: Monad m => (a -> m b) -> [a] -> m [b]+{-# INLINE mapM #-}+mapM f as       =  sequence (map f as)++-- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@.+mapM_           :: Monad m => (a -> m b) -> [a] -> m ()+{-# INLINE mapM_ #-}+mapM_ f as      =  sequence_ (map f as)++#endif  /* __GLASGOW_HASKELL__ */++-- -----------------------------------------------------------------------------+-- The MonadPlus class definition++-- | Monads that also support choice and failure.+class Monad m => MonadPlus m where+   -- | the identity of 'mplus'.  It should also satisfy the equations+   --+   -- > mzero >>= f  =  mzero+   -- > v >> mzero   =  mzero+   --+   -- (but the instance for 'System.IO.IO' defined in Control.Monad.Error+   -- in the mtl package does not satisfy the second one).+   mzero :: m a +   -- | an associative operation+   mplus :: m a -> m a -> m a++instance MonadPlus [] where+   mzero = []+   mplus = (++)++instance MonadPlus Maybe where+   mzero = Nothing++   Nothing `mplus` ys  = ys+   xs      `mplus` _ys = xs++-- -----------------------------------------------------------------------------+-- Functions mandated by the Prelude++-- | @'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++-- | This generalizes the list-based 'filter' function.++filterM          :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+filterM _ []     =  return []+filterM p (x:xs) =  do+   flg <- p x+   ys  <- filterM p xs+   return (if flg then x:ys else ys)++-- | 'forM' is 'mapM' with its arguments flipped+forM            :: Monad m => [a] -> (a -> m b) -> m [b]+{-# INLINE forM #-}+forM            = flip mapM++-- | 'forM_' is 'mapM_' with its arguments flipped+forM_           :: Monad m => [a] -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_           = flip mapM_++-- | This generalizes the list-based 'concat' function.++msum        :: MonadPlus m => [m a] -> m a+{-# INLINE msum #-}+msum        =  foldr mplus mzero++infixr 1 <=<, >=>++-- | Left-to-right Kleisli composition of monads.+(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+f >=> g     = \x -> f x >>= g++-- | Right-to-left Kleisli composition of monads. '(>=>)', with the arguments flipped+(<=<)       :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)+(<=<)       = flip (>=>)++-- | @'forever' act@ repeats the action infinitely.+forever     :: (Monad m) => m a -> m b+forever a   = a >> forever a++-- -----------------------------------------------------------------------------+-- Other monad functions++-- | 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              :: (Monad m) => m (m a) -> m a+join x            =  x >>= id++-- | The 'mapAndUnzipM' function maps its first argument over a list, returning+-- the result as a pair of lists. This function is mainly used with complicated+-- data structures or a state-transforming monad.+mapAndUnzipM      :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs =  sequence (map f xs) >>= return . unzip++-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads.+zipWithM          :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys  =  sequence (zipWith f xs ys)++-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result.+zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++{- | The 'foldM' function is analogous to 'foldl', except that its result is+encapsulated in a monad. Note that 'foldM' works from left-to-right over+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.+-}++foldM             :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM _ a []      =  return a+foldM f a (x:xs)  =  f a x >>= \fax -> foldM f fax xs++-- | Like 'foldM', but discards the result.+foldM_            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()+foldM_ f a xs     = foldM f a xs >> return ()++-- | @'replicateM' n act@ performs the action @n@ times,+-- gathering the results.+replicateM        :: (Monad m) => Int -> m a -> m [a]+replicateM n x    = sequence (replicate n x)++-- | Like 'replicateM', but discards the result.+replicateM_       :: (Monad m) => Int -> m a -> m ()+replicateM_ n x   = sequence_ (replicate n x)++{- | Conditional execution of monadic expressions. For example, ++>       when debug (putStr "Debugging\n")++will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True',+and otherwise do nothing.+-}++when              :: (Monad m) => Bool -> m () -> m ()+when p s          =  if p then s else return ()++-- | The reverse of 'when'.++unless            :: (Monad m) => Bool -> m () -> m ()+unless p s        =  if p then return () else s++-- | 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) }++-- | 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) }++{- | 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                =  liftM2 id+++{- $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: ++>  sum  :: Num a       => [a]   -> a+>  msum :: MonadPlus m => [m a] -> m a++-}
Control/Monad/Fix.hs view
@@ -1,2 +1,79 @@-module Control.Monad.Fix (module X___) where-import "base" Control.Monad.Fix as X___+-----------------------------------------------------------------------------+-- |+-- 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 -- :: (a -> m a) -> m a+         ),+        fix     -- :: (a -> a) -> a+  ) where++import Prelude+import System.IO+import Control.Monad.Instances ()+import Data.Function (fix)+#ifdef __HUGS__+import Hugs.Prelude (MonadFix(mfix))+#endif++#ifndef __HUGS__+-- | Monads having fixed points with a \'knot-tying\' semantics.+-- Instances of 'MonadFix' should satisfy the following laws:+--+-- [/purity/]+--      @'mfix' ('return' . h)  =  '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+#endif /* !__HUGS__ */++-- Instances of MonadFix for Prelude monads++-- Maybe:+instance MonadFix Maybe where+    mfix f = let a = f (unJust a) in a+             where unJust (Just x) = x+                   unJust Nothing  = error "mfix Maybe: Nothing"++-- List:+instance MonadFix [] where+    mfix f = case fix (f . head) of+               []    -> []+               (x:_) -> x : mfix (tail . f)++-- IO:+instance MonadFix IO where+    mfix = fixIO ++instance MonadFix ((->) r) where+    mfix f = \ r -> let a = f a r in a
Control/Monad/Instances.hs view
@@ -1,2 +1,32 @@-module Control.Monad.Instances (module X___) where-import "base" Control.Monad.Instances as X___+{-# OPTIONS_NHC98 --prelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- 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+--+-- 'Functor' and 'Monad' instances for @(->) r@ and+-- 'Functor' instances for @(,) a@ and @'Either' a@.++module Control.Monad.Instances (Functor(..),Monad(..)) where++import Prelude++instance Functor ((->) r) where+        fmap = (.)++instance Monad ((->) r) where+        return = const+        f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+        fmap f (x,y) = (x, f y)++instance Functor (Either a) where+        fmap _ (Left x) = Left x+        fmap f (Right y) = Right (f y)
Control/Monad/ST.hs view
@@ -1,2 +1,65 @@-module Control.Monad.ST (module X___) where-import "base" Control.Monad.ST as X___+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- 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/.+--+-----------------------------------------------------------------------------++module Control.Monad.ST+  (+        -- * The 'ST' Monad+        ST,             -- abstract, instance of Functor, Monad, Typeable.+        runST,          -- :: (forall s. ST s a) -> a+        fixST,          -- :: (a -> ST s a) -> ST s a++        -- * Converting 'ST' to 'IO'+        RealWorld,              -- abstract+        stToIO,                 -- :: ST RealWorld a -> IO a++        -- * Unsafe operations+        unsafeInterleaveST,     -- :: ST s a -> ST s a+        unsafeIOToST,           -- :: IO a -> ST s a+        unsafeSTToIO            -- :: ST s a -> IO a+      ) where++import Prelude++import Control.Monad.Fix++#include "Typeable.h"++#ifdef __HUGS__+import Data.Typeable+import Hugs.ST+import qualified Hugs.LazyST as LazyST++INSTANCE_TYPEABLE2(ST,sTTc,"ST")+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")++fixST :: (a -> ST s a) -> ST s a+fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f))++unsafeInterleaveST :: ST s a -> ST s a+unsafeInterleaveST =+    LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.ST           ( ST, runST, fixST, unsafeInterleaveST )+import GHC.Base         ( RealWorld )+import GHC.IOBase       ( stToIO, unsafeIOToST, unsafeSTToIO )+#endif++instance MonadFix (ST s) where+        mfix = fixST+
Control/Monad/ST/Lazy.hs view
@@ -1,2 +1,152 @@-module Control.Monad.ST.Lazy (module X___) where-import "base" Control.Monad.ST.Lazy as X___+-----------------------------------------------------------------------------+-- |+-- 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,++        -- * Unsafe operations+        unsafeInterleaveST,+        unsafeIOToST+    ) where++import Prelude++import Control.Monad.Fix++import Control.Monad.ST (RealWorld)+import qualified Control.Monad.ST as ST++#ifdef __GLASGOW_HASKELL__+import qualified GHC.ST+import GHC.Base+import Control.Monad+#endif++#ifdef __HUGS__+import Hugs.LazyST+#endif++#ifdef __GLASGOW_HASKELL__+-- | The lazy state-transformer monad.+-- A computation of type @'ST' s a@ transforms an internal state indexed+-- by @s@, and returns a value of type @a@.+-- The @s@ parameter is either+--+-- * an unstantiated 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 (State s -> (a, State s))+data State s = S# (State# s)++instance Functor (ST s) where+    fmap f m = ST $ \ s ->+      let +       ST m_a = m+       (r,new_s) = m_a s+      in+      (f r,new_s)++instance Monad (ST s) where++        return a = ST $ \ s -> (a,s)+        m >> k   =  m >>= \ _ -> k+        fail s   = error s++        (ST m) >>= k+         = ST $ \ s ->+           let+             (r,new_s) = m s+             ST k_a = k r+           in+           k_a new_s++{-# NOINLINE runST #-}+-- | Return the value computed by a state transformer computation.+-- The @forall@ ensures that the internal state used by the 'ST'+-- computation is inaccessible to the rest of the program.+runST :: (forall s. ST s a) -> a+runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r++-- | Allow the result of a state transformer computation to be used (lazily)+-- inside the computation.+-- Note that if @f@ is strict, @'fixST' f = _|_@.+fixST :: (a -> ST s a) -> ST s a+fixST m = ST (\ s -> +                let +                   ST m_r = m r+                   (r,s') = m_r s+                in+                   (r,s'))+#endif++instance MonadFix (ST s) where+        mfix = fixST++-- ---------------------------------------------------------------------------+-- Strict <--> Lazy++#ifdef __GLASGOW_HASKELL__+{-|+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 m = ST $ \s ->+        let +           pr = case s of { S# s# -> GHC.ST.liftST m s# }+           r  = case pr of { GHC.ST.STret _ v -> v }+           s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }+        in+        (r, s')++{-| +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 #)++unsafeInterleaveST :: ST s a -> ST s a+unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST+#endif++unsafeIOToST :: IO a -> ST s a+unsafeIOToST = strictToLazyST . ST.unsafeIOToST++-- | A monad transformer embedding lazy state transformers 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
Control/Monad/ST/Strict.hs view
@@ -1,2 +1,20 @@-module Control.Monad.ST.Strict (module X___) where-import "base" Control.Monad.ST.Strict as X___+-----------------------------------------------------------------------------+-- |+-- 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 Prelude+import Control.Monad.ST
+ Control/OldException.hs view
@@ -0,0 +1,791 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++#include "Typeable.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.OldException+-- 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/.+--+-----------------------------------------------------------------------------++module Control.OldException (++        -- * The Exception type+        Exception(..),          -- instance Eq, Ord, Show, Typeable+        New.IOException,        -- instance Eq, Ord, Show, Typeable+        New.ArithException(..), -- instance Eq, Ord, Show, Typeable+        New.ArrayException(..), -- instance Eq, Ord, Show, Typeable+        New.AsyncException(..), -- instance Eq, Ord, Show, Typeable++        -- * Throwing exceptions+        throwIO,        -- :: Exception -> IO a+        throw,          -- :: Exception -> a+        ioError,        -- :: IOError -> IO a+#ifdef __GLASGOW_HASKELL__+        -- XXX Need to restrict the type of this:+        New.throwTo,        -- :: ThreadId -> Exception -> a+#endif++        -- * Catching Exceptions++        -- |There are several functions for catching and examining+        -- exceptions; all of them may only be used from within the+        -- 'IO' monad.++        -- ** The @catch@ functions+        catch,     -- :: IO a -> (Exception -> IO a) -> IO a+        catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a++        -- ** The @handle@ functions+        handle,    -- :: (Exception -> IO a) -> IO a -> IO a+        handleJust,-- :: (Exception -> Maybe b) -> (b -> IO a) -> IO a -> IO a++        -- ** The @try@ functions+        try,       -- :: IO a -> IO (Either Exception a)+        tryJust,   -- :: (Exception -> Maybe b) -> a    -> IO (Either b a)++        -- ** The @evaluate@ function+        evaluate,  -- :: a -> IO a++        -- ** The @mapException@ function+        mapException,           -- :: (Exception -> Exception) -> a -> a++        -- ** Exception predicates+        +        -- $preds++        ioErrors,               -- :: Exception -> Maybe IOError+        arithExceptions,        -- :: Exception -> Maybe ArithException+        errorCalls,             -- :: Exception -> Maybe String+        dynExceptions,          -- :: Exception -> Maybe Dynamic+        assertions,             -- :: Exception -> Maybe String+        asyncExceptions,        -- :: Exception -> Maybe AsyncException+        userErrors,             -- :: Exception -> Maybe String++        -- * Dynamic exceptions++        -- $dynamic+        throwDyn,       -- :: Typeable ex => ex -> b+#ifdef __GLASGOW_HASKELL__+        throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b+#endif+        catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a+        +        -- * Asynchronous Exceptions++        -- $async++        -- ** Asynchronous exception control++        -- |The following two functions allow a thread to control delivery of+        -- asynchronous exceptions during a critical region.++        block,          -- :: IO a -> IO a+        unblock,        -- :: IO a -> IO a++        -- *** Applying @block@ to an exception handler++        -- $block_handler++        -- *** Interruptible operations++        -- $interruptible++        -- * Assertions++        assert,         -- :: Bool -> a -> a++        -- * Utilities++        bracket,        -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()+        bracket_,       -- :: IO a -> IO b -> IO c -> IO ()+        bracketOnError,++        finally,        -- :: IO a -> IO b -> IO a+        +#ifdef __GLASGOW_HASKELL__+        setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()+        getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Num+import GHC.Show+import GHC.IOBase ( IO )+import qualified GHC.IOBase as New+import GHC.Conc hiding (setUncaughtExceptionHandler,+                        getUncaughtExceptionHandler)+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )+import Foreign.C.String ( CString, withCString )+import GHC.Handle       ( stdout, hFlush )+#endif++#ifdef __HUGS__+import Prelude          hiding (catch)+import Hugs.Prelude     as New (ExitCode(..))+#endif++import qualified Control.Exception as New+import           Control.Exception ( toException, fromException, throw, block, unblock, evaluate, throwIO )+import System.IO.Error  hiding ( catch, try )+import System.IO.Unsafe (unsafePerformIO)+import Data.Dynamic+import Data.Either+import Data.Maybe++#ifdef __NHC__+import System.IO.Error (catch, ioError)+import IO              (bracket)+import DIOError         -- defn of IOError type++-- minimum needed for nhc98 to pretend it has Exceptions+type Exception   = IOError+type IOException = IOError+data ArithException+data ArrayException+data AsyncException++throwIO  :: Exception -> IO a+throwIO   = ioError+throw    :: Exception -> a+throw     = unsafePerformIO . throwIO++evaluate :: a -> IO a+evaluate x = x `seq` return x++ioErrors        :: Exception -> Maybe IOError+ioErrors e       = Just e+arithExceptions :: Exception -> Maybe ArithException+arithExceptions  = const Nothing+errorCalls      :: Exception -> Maybe String+errorCalls       = const Nothing+dynExceptions   :: Exception -> Maybe Dynamic+dynExceptions    = const Nothing+assertions      :: Exception -> Maybe String+assertions       = const Nothing+asyncExceptions :: Exception -> Maybe AsyncException+asyncExceptions  = const Nothing+userErrors      :: Exception -> Maybe String+userErrors (UserError _ s) = Just s+userErrors  _              = Nothing++block   :: IO a -> IO a+block    = id+unblock :: IO a -> IO a+unblock  = id++assert :: Bool -> a -> a+assert True  x = x+assert False _ = throw (UserError "" "Assertion failed")+#endif++-----------------------------------------------------------------------------+-- Catching exceptions++-- |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 (openFile f ReadMode) +-- >       (\e -> hPutStr stderr ("Couldn't open "++f++": " ++ show e))+--+-- For catching exceptions in pure (non-'IO') expressions, see the+-- function 'evaluate'.+--+-- Note that due to Haskell\'s unspecified evaluation order, an+-- expression may return one of several possible exceptions: consider+-- the expression @error \"urk\" + 1 \`div\` 0@.  Does+-- 'catch' execute the handler passing+-- @ErrorCall \"urk\"@, or @ArithError DivideByZero@?+--+-- The answer is \"either\": 'catch' makes a+-- non-deterministic choice about which exception to catch.  If you+-- call it again, you might get a different exception back.  This is+-- ok, because 'catch' is an 'IO' computation.+--+-- Note that 'catch' catches all types of exceptions, and is generally+-- used for \"cleaning up\" before passing on the exception using+-- 'throwIO'.  It is not good practice to discard the exception and+-- continue, without first checking the type of the exception (it+-- might be a 'ThreadKilled', for example).  In this case it is usually better+-- to use 'catchJust' and select the kinds of exceptions to catch.+--+-- Also note that the "Prelude" also exports a function called+-- 'Prelude.catch' with a similar type to 'Control.OldException.catch',+-- except that the "Prelude" version only catches the IO and user+-- families of exceptions (as required by Haskell 98).  +--+-- We recommend either hiding the "Prelude" version of 'Prelude.catch'+-- when importing "Control.OldException": +--+-- > import Prelude hiding (catch)+--+-- or importing "Control.OldException" qualified, to avoid name-clashes:+--+-- > import qualified Control.OldException as C+--+-- and then using @C.catch@+--++catch   :: IO a                 -- ^ The computation to run+        -> (Exception -> IO a)  -- ^ Handler to invoke if an exception is raised+        -> IO a+-- note: bundling the exceptions is done in the New.Exception+-- instance of Exception; see below.+catch = New.catch++-- | 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.  There are+-- some predefined exception predicates for useful subsets of+-- exceptions: 'ioErrors', 'arithExceptions', and so on.  For example,+-- to catch just calls to the 'error' function, we could use+--+-- >   result <- catchJust errorCalls thing_to_try handler+--+-- Any other exceptions which are not matched by the predicate+-- are re-raised, and may be caught by an enclosing+-- 'catch' or 'catchJust'.+catchJust+        :: (Exception -> 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 -> throw 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 (\e -> exitWith (ExitFailure 1)) $+-- >      ...+handle     :: (Exception -> IO a) -> IO a -> IO a+handle     =  flip catch++-- | A version of 'catchJust' with the arguments swapped around (see+-- 'handle').+handleJust :: (Exception -> 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 -> Exception) -> a -> a+mapException f v = unsafePerformIO (catch (evaluate v)+                                          (\x -> throw (f x)))++-----------------------------------------------------------------------------+-- 'try' and variations.++-- | Similar to 'catch', but returns an 'Either' result which is+-- @('Right' a)@ if no exception was raised, or @('Left' e)@ if an+-- exception was raised and its value is @e@.+--+-- >  try a = catch (Right `liftM` a) (return . Left)+--+-- Note: as with 'catch', it is only polite to use this variant if you intend+-- to re-throw the exception after performing whatever cleanup is needed.+-- Otherwise, 'tryJust' is generally considered to be better.+--+-- Also note that "System.IO.Error" also exports a function called+-- 'System.IO.Error.try' with a similar type to 'Control.OldException.try',+-- except that it catches only the IO and user families of exceptions+-- (as required by the Haskell 98 @IO@ module).++try :: IO a -> IO (Either Exception 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 -> 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 -> throw e+                        Just b  -> return (Left b)++-----------------------------------------------------------------------------+-- Dynamic exceptions++-- $dynamic+--  #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an+-- interface for throwing and catching exceptions of type 'Dynamic'+-- (see "Data.Dynamic") which allows exception values of any type in+-- the 'Typeable' class to be thrown and caught.++-- | Raise any value as an exception, provided it is in the+-- 'Typeable' class.+throwDyn :: Typeable exception => exception -> b+#ifdef __NHC__+throwDyn exception = throw (UserError "" "dynamic exception")+#else+throwDyn exception = throw (DynException (toDyn exception))+#endif++#ifdef __GLASGOW_HASKELL__+-- | A variant of 'throwDyn' that throws the dynamic exception to an+-- arbitrary thread (GHC only: c.f. 'throwTo').+throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()+throwDynTo t exception = New.throwTo t (DynException (toDyn exception))+#endif /* __GLASGOW_HASKELL__ */++-- | Catch dynamic exceptions of the required type.  All other+-- exceptions are re-thrown, including dynamic exceptions of the wrong+-- type.+--+-- When using dynamic exceptions it is advisable to define a new+-- datatype to use for your exception type, to avoid possible clashes+-- with dynamic exceptions used in other libraries.+--+catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a+#ifdef __NHC__+catchDyn m k = m        -- can't catch dyn exceptions in nhc98+#else+catchDyn m k = New.catch m handler+  where handler ex = case ex of+                           (DynException dyn) ->+                                case fromDynamic dyn of+                                    Just exception  -> k exception+                                    Nothing -> throw ex+                           _ -> throw ex+#endif++-----------------------------------------------------------------------------+-- Exception Predicates++-- $preds+-- These pre-defined predicates may be used as the first argument to+-- 'catchJust', 'tryJust', or 'handleJust' to select certain common+-- classes of exceptions.+#ifndef __NHC__+ioErrors                :: Exception -> Maybe IOError+arithExceptions         :: Exception -> Maybe New.ArithException+errorCalls              :: Exception -> Maybe String+assertions              :: Exception -> Maybe String+dynExceptions           :: Exception -> Maybe Dynamic+asyncExceptions         :: Exception -> Maybe New.AsyncException+userErrors              :: Exception -> Maybe String++ioErrors (IOException e) = Just e+ioErrors _ = Nothing++arithExceptions (ArithException e) = Just e+arithExceptions _ = Nothing++errorCalls (ErrorCall e) = Just e+errorCalls _ = Nothing++assertions (AssertionFailed e) = Just e+assertions _ = Nothing++dynExceptions (DynException e) = Just e+dynExceptions _ = Nothing++asyncExceptions (AsyncException e) = Just e+asyncExceptions _ = Nothing++userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e)+userErrors _ = Nothing+#endif+-----------------------------------------------------------------------------+-- 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)+-- >   (\handle -> 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+--+#ifndef __NHC__+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 =+  block (do+    a <- before +    r <- catch +           (unblock (thing a))+           (\e -> do { after a; throw e })+    after a+    return r+ )+#endif++-- | 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 =+  block (do+    r <- catch +             (unblock a)+             (\e -> do { sequel; throw e })+    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 =+  block (do+    a <- before +    catch +        (unblock (thing a))+        (\e -> do { after a; throw e })+ )++-- -----------------------------------------------------------------------------+-- Asynchronous exceptions++{- $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 'throwDynTo' and '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 'block' 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 blocked 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++>      block (+>           catch (unblock (...))+>                      (\e -> handler)+>      )++If you need to unblock asynchronous exceptions again in the exception+handler, just use 'unblock' as normal.++Note that 'try' and friends /do not/ have a similar default, because+there is no exception handler in this case.  If you want to use 'try'+in an asynchronous-exception-safe way, you will need to use+'block'.+-}++{- $interruptible++Some operations are /interruptible/, which means that they can receive+asynchronous exceptions even in the scope of a 'block'.  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++>      block (+>         a <- takeMVar m+>         catch (unblock (...))+>               (\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'.+-}++#if !(__GLASGOW_HASKELL__ || __NHC__)+assert :: Bool -> a -> a+assert True x = x+assert False _ = throw (AssertionFailed "")+#endif+++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE uncaughtExceptionHandler #-}+uncaughtExceptionHandler :: IORef (Exception -> IO ())+uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)+   where+      defaultHandler :: Exception -> IO ()+      defaultHandler ex = do+         (hFlush stdout) `New.catchAny` (\ _ -> return ())+         let msg = case ex of+               Deadlock    -> "no threads to run:  infinite loop or deadlock?"+               ErrorCall s -> s+               other       -> showsPrec 0 other ""+         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 :: (Exception -> IO ()) -> IO ()+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler++getUncaughtExceptionHandler :: IO (Exception -> IO ())+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler+#endif++-- ------------------------------------------------------------------------+-- Exception datatype and operations++-- |The type of exceptions.  Every kind of system-generated exception+-- has a constructor in the 'Exception' type, and values of other+-- types may be injected into 'Exception' by coercing them to+-- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:+-- "Control.OldException\#DynamicExceptions").+data Exception+  = ArithException      New.ArithException+        -- ^Exceptions raised by arithmetic+        -- operations.  (NOTE: GHC currently does not throw+        -- 'ArithException's except for 'DivideByZero').+  | ArrayException      New.ArrayException+        -- ^Exceptions raised by array-related+        -- operations.  (NOTE: GHC currently does not throw+        -- 'ArrayException's).+  | AssertionFailed     String+        -- ^This exception is thrown by the+        -- 'assert' operation when the condition+        -- fails.  The 'String' argument contains the+        -- location of the assertion in the source program.+  | AsyncException      New.AsyncException+        -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.OldException\#AsynchronousExceptions").+  | BlockedOnDeadMVar+        -- ^The current thread was executing a call to+        -- 'Control.Concurrent.MVar.takeMVar' that could never return,+        -- because there are no other references to this 'MVar'.+  | BlockedIndefinitely+        -- ^The current thread was waiting to retry an atomic memory transaction+        -- that could never become possible to complete because there are no other+        -- threads referring to any of the TVars involved.+  | NestedAtomically+        -- ^The runtime detected an attempt to nest one STM transaction+        -- inside another one, presumably due to the use of +        -- 'unsafePeformIO' with 'atomically'.+  | Deadlock+        -- ^There are no runnable threads, so the program is+        -- deadlocked.  The 'Deadlock' exception is+        -- raised in the main thread only (see also: "Control.Concurrent").+  | DynException        Dynamic+        -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.OldException\#DynamicExceptions").+  | ErrorCall           String+        -- ^The 'ErrorCall' exception is thrown by 'error'.  The 'String'+        -- argument of 'ErrorCall' is the string passed to 'error' when it was+        -- called.+  | ExitException       New.ExitCode+        -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and+        -- 'System.Exit.exitFailure').  The 'ExitCode' argument is the value passed +        -- to 'System.Exit.exitWith'.  An unhandled 'ExitException' exception in the+        -- main thread will cause the program to be terminated with the given +        -- exit code.+  | IOException         New.IOException+        -- ^These are the standard IO exceptions generated by+        -- Haskell\'s @IO@ operations.  See also "System.IO.Error".+  | NoMethodError       String+        -- ^An attempt was made to invoke a class method which has+        -- no definition in this instance, and there was no default+        -- definition given in the class declaration.  GHC issues a+        -- warning when you compile an instance which has missing+        -- methods.+  | NonTermination+        -- ^The current thread is stuck in an infinite loop.  This+        -- exception may or may not be thrown when the program is+        -- non-terminating.+  | PatternMatchFail    String+        -- ^A pattern matching failure.  The 'String' argument should contain a+        -- descriptive message including the function name, source file+        -- and line number.+  | RecConError         String+        -- ^An attempt was made to evaluate a field of a record+        -- for which no value was given at construction time.  The+        -- 'String' argument gives the location of the+        -- record construction in the source program.+  | RecSelError         String+        -- ^A field selection was attempted on a constructor that+        -- doesn\'t have the requested field.  This can happen with+        -- multi-constructor records when one or more fields are+        -- missing from some of the constructors.  The+        -- 'String' argument gives the location of the+        -- record selection in the source program.+  | RecUpdError         String+        -- ^An attempt was made to update a field in a record,+        -- where the record doesn\'t have the requested field.  This can+        -- only occur with multi-constructor records, when one or more+        -- fields are missing from some of the constructors.  The+        -- 'String' argument gives the location of the+        -- record update in the source program.+INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")++-- helper type for simplifying the type casting logic below+data Caster = forall e . New.Exception e => Caster (e -> Exception)++instance New.Exception Exception where+  -- We need to collect all the sorts of exceptions that used to be+  -- bundled up into the Exception type, and rebundle them for+  -- legacy handlers.+  fromException exc0 = foldr tryCast Nothing casters where+    tryCast (Caster f) e = case fromException exc0 of+      Just exc -> Just (f exc)+      _        -> e+    casters =+      [Caster (\exc -> ArithException exc),+       Caster (\exc -> ArrayException exc),+       Caster (\(New.AssertionFailed err) -> AssertionFailed err),+       Caster (\exc -> AsyncException exc),+       Caster (\New.BlockedOnDeadMVar -> BlockedOnDeadMVar),+       Caster (\New.BlockedIndefinitely -> BlockedIndefinitely),+       Caster (\New.NestedAtomically -> NestedAtomically),+       Caster (\New.Deadlock -> Deadlock),+       Caster (\exc -> DynException exc),+       Caster (\(New.ErrorCall err) -> ErrorCall err),+       Caster (\exc -> ExitException exc),+       Caster (\exc -> IOException exc),+       Caster (\(New.NoMethodError err) -> NoMethodError err),+       Caster (\New.NonTermination -> NonTermination),+       Caster (\(New.PatternMatchFail err) -> PatternMatchFail err),+       Caster (\(New.RecConError err) -> RecConError err),+       Caster (\(New.RecSelError err) -> RecSelError err),+       Caster (\(New.RecUpdError err) -> RecUpdError err)]++  -- Unbundle exceptions.+  toException (ArithException exc)   = toException exc+  toException (ArrayException exc)   = toException exc+  toException (AssertionFailed err)  = toException (New.AssertionFailed err)+  toException (AsyncException exc)   = toException exc+  toException BlockedOnDeadMVar      = toException New.BlockedOnDeadMVar+  toException BlockedIndefinitely    = toException New.BlockedIndefinitely+  toException NestedAtomically       = toException New.NestedAtomically+  toException Deadlock               = toException New.Deadlock+  toException (DynException exc)     = toException exc+  toException (ErrorCall err)        = toException (New.ErrorCall err)+  toException (ExitException exc)    = toException exc+  toException (IOException exc)      = toException exc+  toException (NoMethodError err)    = toException (New.NoMethodError err)+  toException NonTermination         = toException New.NonTermination+  toException (PatternMatchFail err) = toException (New.PatternMatchFail err)+  toException (RecConError err)      = toException (New.RecConError err)+  toException (RecSelError err)      = toException (New.RecSelError err)+  toException (RecUpdError err)      = toException (New.RecUpdError err)++instance Show Exception where+  showsPrec _ (IOException err)          = shows err+  showsPrec _ (ArithException err)       = shows err+  showsPrec _ (ArrayException err)       = shows err+  showsPrec _ (ErrorCall err)            = showString err+  showsPrec _ (ExitException err)        = showString "exit: " . shows err+  showsPrec _ (NoMethodError err)        = showString err+  showsPrec _ (PatternMatchFail err)     = showString err+  showsPrec _ (RecSelError err)          = showString err+  showsPrec _ (RecConError err)          = showString err+  showsPrec _ (RecUpdError err)          = showString err+  showsPrec _ (AssertionFailed err)      = showString err+  showsPrec _ (DynException err)         = showString "exception :: " . showsTypeRep (dynTypeRep err)+  showsPrec _ (AsyncException e)         = shows e+  showsPrec p BlockedOnDeadMVar          = showsPrec p New.BlockedOnDeadMVar+  showsPrec p BlockedIndefinitely        = showsPrec p New.BlockedIndefinitely+  showsPrec p NestedAtomically           = showsPrec p New.NestedAtomically+  showsPrec p NonTermination             = showsPrec p New.NonTermination+  showsPrec p Deadlock                   = showsPrec p New.Deadlock++instance Eq Exception where+  IOException e1      == IOException e2      = e1 == e2+  ArithException e1   == ArithException e2   = e1 == e2+  ArrayException e1   == ArrayException e2   = e1 == e2+  ErrorCall e1        == ErrorCall e2        = e1 == e2+  ExitException e1    == ExitException e2    = e1 == e2+  NoMethodError e1    == NoMethodError e2    = e1 == e2+  PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2+  RecSelError e1      == RecSelError e2      = e1 == e2+  RecConError e1      == RecConError e2      = e1 == e2+  RecUpdError e1      == RecUpdError e2      = e1 == e2+  AssertionFailed e1  == AssertionFailed e2  = e1 == e2+  DynException _      == DynException _      = False -- incomparable+  AsyncException e1   == AsyncException e2   = e1 == e2+  BlockedOnDeadMVar   == BlockedOnDeadMVar   = True+  NonTermination      == NonTermination      = True+  NestedAtomically    == NestedAtomically    = True+  Deadlock            == Deadlock            = True+  _                   == _                   = False+
Data/Bits.hs view
@@ -1,2 +1,360 @@-module Data.Bits (module X___) where-import "base" Data.Bits as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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 ( +  Bits(+    (.&.), (.|.), xor, -- :: a -> a -> a+    complement,        -- :: a -> a+    shift,             -- :: a -> Int -> a+    rotate,            -- :: a -> Int -> a+    bit,               -- :: Int -> a+    setBit,            -- :: a -> Int -> a+    clearBit,          -- :: a -> Int -> a+    complementBit,     -- :: a -> Int -> a+    testBit,           -- :: a -> Int -> Bool+    bitSize,           -- :: a -> Int+    isSigned,          -- :: a -> Bool+    shiftL, shiftR,    -- :: a -> Int -> a+    rotateL, rotateR   -- :: a -> Int -> a+  )++  -- instance Bits Int+  -- instance Bits Integer+ ) where++-- Defines the @Bits@ class containing bit-based operations.+-- See library document for details on the semantics of the+-- individual operations.++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+#include "MachDeps.h"+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Num+import GHC.Real+import GHC.Base+#endif++#ifdef __HUGS__+import Hugs.Bits+#endif++infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`+infixl 7 .&.+infixl 6 `xor`+infixl 5 .|.++{-| +The 'Bits' class defines bitwise operations over integral types.++* Bits are numbered from 0 with bit 0 being the least+  significant bit.++Minimal complete definition: '.&.', '.|.', 'xor', 'complement',+('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),+'bitSize' and 'isSigned'.+-}+class Num a => Bits a where+    -- | 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))+    -}++    -- | @bit i@ is a value with the @i@th bit set+    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++    -- | Return 'True' if the @n@th bit of the argument is 1+    testBit           :: a -> Int -> Bool++    {-| 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'.+        -}+    bitSize           :: a -> Int++    {-| Return 'True' if the argument is a signed type.  The actual+        value of the argument is ignored -}+    isSigned          :: a -> Bool++    bit i               = 1 `shiftL` i+    x `setBit` i        = x .|. bit i+    x `clearBit` i      = x .&. complement (bit i)+    x `complementBit` i = x `xor` bit i+    x `testBit` i       = (x .&. bit i) /= 0++    {-| Shift the argument left by the specified number of bits+        (which must be non-negative).++        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+    x `shiftL`  i = x `shift`  i++    {-| Shift the first argument right by the specified number of bits+        (which must be non-negative).+        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+    x `shiftR`  i = x `shift`  (-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+    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+    x `rotateR` i = x `rotate` (-i)++instance Bits Int where+    {-# INLINE shift #-}++#ifdef __GLASGOW_HASKELL__+    (I# x#) .&.   (I# y#)  = I# (word2Int# (int2Word# x# `and#` int2Word# y#))++    (I# x#) .|.   (I# y#)  = I# (word2Int# (int2Word# x# `or#`  int2Word# y#))++    (I# x#) `xor` (I# y#)  = I# (word2Int# (int2Word# x# `xor#` int2Word# y#))++    complement (I# x#)     = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))++    (I# x#) `shift` (I# i#)+        | i# >=# 0#        = I# (x# `iShiftL#` i#)+        | otherwise        = I# (x# `iShiftRA#` negateInt# i#)++    {-# INLINE rotate #-} 	-- See Note [Constant folding for rotate]+    (I# x#) `rotate` (I# i#) =+        I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                       (x'# `uncheckedShiftRL#` (wsib -# i'#))))+      where+        x'# = int2Word# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        wsib = WORD_SIZE_IN_BITS#   {- work around preprocessor problem (??) -}+    bitSize  _             = WORD_SIZE_IN_BITS++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)+#else /* !__GLASGOW_HASKELL__ */++#ifdef __HUGS__+    (.&.)                  = primAndInt+    (.|.)                  = primOrInt+    xor                    = primXorInt+    complement             = primComplementInt+    shift                  = primShiftInt+    bit                    = primBitInt+    testBit                = primTestInt+    bitSize _              = SIZEOF_HSINT*8+#elif defined(__NHC__)+    (.&.)                  = nhc_primIntAnd+    (.|.)                  = nhc_primIntOr+    xor                    = nhc_primIntXor+    complement             = nhc_primIntCompl+    shiftL                 = nhc_primIntLsh+    shiftR                 = nhc_primIntRsh+    bitSize _              = 32+#endif /* __NHC__ */++    x `rotate`  i+        | i<0 && 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))++#endif /* !__GLASGOW_HASKELL__ */++    isSigned _             = True++#ifdef __NHC__+foreign import ccall nhc_primIntAnd :: Int -> Int -> Int+foreign import ccall nhc_primIntOr  :: Int -> Int -> Int+foreign import ccall nhc_primIntXor :: Int -> Int -> Int+foreign import ccall nhc_primIntLsh :: Int -> Int -> Int+foreign import ccall nhc_primIntRsh :: Int -> Int -> Int+foreign import ccall nhc_primIntCompl :: Int -> Int+#endif /* __NHC__ */++instance Bits Integer where+#if defined(__GLASGOW_HASKELL__)+   (.&.) = andInteger+   (.|.) = orInteger+   xor = xorInteger+   complement = complementInteger+#else+   -- reduce bitwise binary operations to special cases we can handle++   x .&. y   | x<0 && y<0 = complement (complement x `posOr` complement y)+             | otherwise  = x `posAnd` y+   +   x .|. y   | x<0 || y<0 = complement (complement x `posAnd` complement y)+             | otherwise  = x `posOr` y+   +   x `xor` y | x<0 && y<0 = complement x `posXOr` complement y+             | x<0        = complement (complement x `posXOr` y)+             |        y<0 = complement (x `posXOr` complement y)+             | otherwise  = x `posXOr` y++   -- assuming infinite 2's-complement arithmetic+   complement a = -1 - a+#endif++   shift x i | i >= 0    = x * 2^i+             | otherwise = x `div` 2^(-i)++   rotate x i = shift x i   -- since an Integer never wraps around++   bitSize _  = error "Data.Bits.bitSize(Integer)"+   isSigned _ = True++#if !defined(__GLASGOW_HASKELL__)+-- Crude implementation of bitwise operations on Integers: convert them+-- to finite lists of Ints (least significant first), zip and convert+-- back again.++-- posAnd requires at least one argument non-negative+-- posOr and posXOr require both arguments non-negative++posAnd, posOr, posXOr :: Integer -> Integer -> Integer+posAnd x y   = fromInts $ zipWith (.&.) (toInts x) (toInts y)+posOr x y    = fromInts $ longZipWith (.|.) (toInts x) (toInts y)+posXOr x y   = fromInts $ longZipWith xor (toInts x) (toInts y)++longZipWith :: (a -> a -> a) -> [a] -> [a] -> [a]+longZipWith f xs [] = xs+longZipWith f [] ys = ys+longZipWith f (x:xs) (y:ys) = f x y:longZipWith f xs ys++toInts :: Integer -> [Int]+toInts n+    | n == 0 = []+    | otherwise = mkInt (n `mod` numInts):toInts (n `div` numInts)+  where mkInt n | n > toInteger(maxBound::Int) = fromInteger (n-numInts)+                | otherwise = fromInteger n++fromInts :: [Int] -> Integer+fromInts = foldr catInt 0+    where catInt d n = (if d<0 then n+1 else n)*numInts + toInteger d++numInts = toInteger (maxBound::Int) - toInteger (minBound::Int) + 1+#endif /* !__GLASGOW_HASKELL__ */++{- 	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+         }+-} +     +
Data/Bool.hs view
@@ -1,2 +1,39 @@-module Data.Bool (module X___) where-import "base" Data.Bool as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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 +   (&&),        -- :: Bool -> Bool -> Bool+   (||),        -- :: Bool -> Bool -> Bool+   not,         -- :: Bool -> Bool+   otherwise,   -- :: Bool+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#endif++#ifdef __NHC__+import Prelude+import Prelude+  ( Bool(..)+  , (&&)+  , (||)+  , not+  , otherwise+  )+#endif
Data/Char.hs view
@@ -1,2 +1,211 @@-module Data.Char (module X___) where-import "base" Data.Char as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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++    , String++    -- * 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  -- :: Char -> Char++    -- * Single digit characters+    , digitToInt        -- :: Char -> Int+    , intToDigit        -- :: Int  -> Char++    -- * Numeric representations+    , ord               -- :: Char -> Int+    , chr               -- :: Int  -> Char++    -- * String representations+    , showLitChar       -- :: Char -> ShowS+    , lexLitChar        -- :: ReadS String+    , readLitChar       -- :: ReadS Char ++     -- Implementation checked wrt. Haskell 98 lib report, 1/99.+    ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Arr (Ix)+import GHC.Real (fromIntegral)+import GHC.Show+import GHC.Read (Read, readLitChar, lexLitChar)+import GHC.Unicode+import GHC.Num+import GHC.Enum+#endif++#ifdef __HUGS__+import Hugs.Prelude (Ix)+import Hugs.Char+#endif++#ifdef __NHC__+import Prelude+import Prelude(Char,String)+import Char+import Ix+import NHC.FFI (CInt)+foreign import ccall unsafe "WCsubst.h u_gencat" wgencat :: CInt -> CInt+#endif++-- | 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+-- (i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).+digitToInt :: Char -> Int+digitToInt c+ | isDigit c            =  ord c - ord '0'+ | c >= 'a' && c <= 'f' =  ord c - ord 'a' + 10+ | c >= 'A' && c <= 'F' =  ord c - ord 'A' + 10+ | otherwise            =  error ("Char.digitToInt: not a digit " ++ show c) -- sigh++#ifndef __GLASGOW_HASKELL__+isAsciiUpper, isAsciiLower :: Char -> Bool+isAsciiLower c          =  c >= 'a' && c <= 'z'+isAsciiUpper c          =  c >= 'A' && c <= 'Z'+#endif++-- | Unicode General Categories (column 2 of the UnicodeData table)+-- in the order they are listed in the Unicode standard.++data GeneralCategory+        = UppercaseLetter       -- ^ Lu: Letter, Uppercase+        | LowercaseLetter       -- ^ Ll: Letter, Lowercase+        | TitlecaseLetter       -- ^ Lt: Letter, Titlecase+        | ModifierLetter        -- ^ Lm: Letter, Modifier+        | OtherLetter           -- ^ Lo: Letter, Other+        | NonSpacingMark        -- ^ Mn: Mark, Non-Spacing+        | SpacingCombiningMark  -- ^ Mc: Mark, Spacing Combining+        | EnclosingMark         -- ^ Me: Mark, Enclosing+        | DecimalNumber         -- ^ Nd: Number, Decimal+        | LetterNumber          -- ^ Nl: Number, Letter+        | OtherNumber           -- ^ No: Number, Other+        | ConnectorPunctuation  -- ^ Pc: Punctuation, Connector+        | DashPunctuation       -- ^ Pd: Punctuation, Dash+        | OpenPunctuation       -- ^ Ps: Punctuation, Open+        | ClosePunctuation      -- ^ Pe: Punctuation, Close+        | InitialQuote          -- ^ Pi: Punctuation, Initial quote+        | FinalQuote            -- ^ Pf: Punctuation, Final quote+        | OtherPunctuation      -- ^ Po: Punctuation, Other+        | MathSymbol            -- ^ Sm: Symbol, Math+        | CurrencySymbol        -- ^ Sc: Symbol, Currency+        | ModifierSymbol        -- ^ Sk: Symbol, Modifier+        | OtherSymbol           -- ^ So: Symbol, Other+        | Space                 -- ^ Zs: Separator, Space+        | LineSeparator         -- ^ Zl: Separator, Line+        | ParagraphSeparator    -- ^ Zp: Separator, Paragraph+        | Control               -- ^ Cc: Other, Control+        | Format                -- ^ Cf: Other, Format+        | Surrogate             -- ^ Cs: Other, Surrogate+        | PrivateUse            -- ^ Co: Other, Private Use+        | NotAssigned           -- ^ Cn: Other, Not Assigned+        deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)++-- | The Unicode general category of the character.+generalCategory :: Char -> GeneralCategory+#if defined(__GLASGOW_HASKELL__) || defined(__NHC__)+generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c+#endif+#ifdef __HUGS__+generalCategory c = toEnum (primUniGenCat c)+#endif++-- 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'.+isLetter :: Char -> Bool+isLetter c = case generalCategory c of+        UppercaseLetter         -> True+        LowercaseLetter         -> True+        TitlecaseLetter         -> True+        ModifierLetter          -> True+        OtherLetter             -> True+        _                       -> False++-- | Selects Unicode mark characters, e.g. accents and the like, which+-- combine with preceding letters.+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, etc.+isNumber :: Char -> Bool+isNumber c = case generalCategory c of+        DecimalNumber           -> True+        LetterNumber            -> True+        OtherNumber             -> True+        _                       -> False++-- | Selects Unicode punctuation characters, including various kinds+-- of connectors, brackets and quotes.+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.+isSymbol :: Char -> Bool+isSymbol c = case generalCategory c of+        MathSymbol              -> True+        CurrencySymbol          -> True+        ModifierSymbol          -> True+        OtherSymbol             -> True+        _                       -> False++-- | Selects Unicode space and separator characters.+isSeparator :: Char -> Bool+isSeparator c = case generalCategory c of+        Space                   -> True+        LineSeparator           -> True+        ParagraphSeparator      -> True+        _                       -> False++#ifdef __NHC__+-- dummy implementation+toTitle :: Char -> Char+toTitle = toUpper+#endif
Data/Complex.hs view
@@ -1,2 +1,201 @@-module Data.Complex (module X___) where-import "base" Data.Complex as X___+-----------------------------------------------------------------------------+-- |+-- 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      -- :: (RealFloat a) => Complex a -> a+        , imagPart      -- :: (RealFloat a) => Complex a -> a+        -- * Polar form+        , mkPolar       -- :: (RealFloat a) => a -> a -> Complex a+        , cis           -- :: (RealFloat a) => a -> Complex a+        , polar         -- :: (RealFloat a) => Complex a -> (a,a)+        , magnitude     -- :: (RealFloat a) => Complex a -> a+        , phase         -- :: (RealFloat a) => Complex a -> a+        -- * Conjugate+        , conjugate     -- :: (RealFloat a) => Complex a -> Complex a++        -- Complex instances:+        --+        --  (RealFloat a) => Eq         (Complex a)+        --  (RealFloat a) => Read       (Complex a)+        --  (RealFloat a) => Show       (Complex a)+        --  (RealFloat a) => Num        (Complex a)+        --  (RealFloat a) => Fractional (Complex a)+        --  (RealFloat a) => Floating   (Complex a)+        -- +        -- Implementation checked wrt. Haskell 98 lib report, 1/99.++        )  where++import Prelude++import Data.Typeable+#ifdef __GLASGOW_HASKELL__+import Data.Data (Data)+#endif++#ifdef __HUGS__+import Hugs.Prelude(Num(fromInt), Fractional(fromDouble))+#endif++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.+data (RealFloat a) => Complex a+  = !a :+ !a    -- ^ forms a complex number from its real and imaginary+                -- rectangular components.+# if __GLASGOW_HASKELL__+        deriving (Eq, Show, Read, Data)+# else+        deriving (Eq, Show, Read)+# endif++-- -----------------------------------------------------------------------------+-- Functions over Complex++-- | Extracts the real part of a complex number.+realPart :: (RealFloat a) => Complex a -> a+realPart (x :+ _) =  x++-- | Extracts the imaginary part of a complex number.+imagPart :: (RealFloat a) => Complex a -> a+imagPart (_ :+ y) =  y++-- | The conjugate of a complex number.+{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}+conjugate        :: (RealFloat 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          :: (RealFloat 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              :: (RealFloat 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++#include "Typeable.h"+INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")++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+#ifdef __HUGS__+    fromInt n           =  fromInt n :+ 0+#endif++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+#ifdef __HUGS__+    fromDouble a        =  fromDouble a :+ 0+#endif++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++    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))+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    atanh z        =  log ((1+z) / sqrt (1-z*z))
+ Data/Data.hs view
@@ -0,0 +1,1288 @@+-----------------------------------------------------------------------------+-- |+-- 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.cs.vu.nl/boilerplate/>. 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,         -- :: ... -> a -> c a+                gunfold,        -- :: ... -> Constr -> c a+                toConstr,       -- :: a -> Constr+                dataTypeOf,     -- :: a -> DataType+                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, instance of: Show+        -- ** Constructors+        mkDataType,     -- :: String   -> [Constr] -> DataType+        mkIntType,      -- :: String -> DataType+        mkFloatType,    -- :: String -> DataType+        mkStringType,   -- :: String -> DataType+        mkNorepType,    -- :: String -> DataType+        -- ** Observers+        dataTypeName,   -- :: DataType -> String+        DataRep(..),    -- instance of: Eq, Show+        dataTypeRep,    -- :: DataType -> DataRep+        -- ** Convenience functions+        repConstr,      -- :: DataType -> ConstrRep -> Constr+        isAlgType,      -- :: DataType -> Bool+        dataTypeConstrs,-- :: DataType -> [Constr]+        indexConstr,    -- :: DataType -> ConIndex -> Constr+        maxConstrIndex, -- :: DataType -> ConIndex+        isNorepType,    -- :: DataType -> Bool++        -- * Data constructor representations+        Constr,         -- abstract, instance of: Eq, Show+        ConIndex,       -- alias for Int, start at 1+        Fixity(..),     -- instance of: Eq, Show+        -- ** Constructors+        mkConstr,       -- :: DataType -> String -> Fixity -> Constr+        mkIntConstr,    -- :: DataType -> Integer -> Constr+        mkFloatConstr,  -- :: DataType -> Double  -> Constr+        mkStringConstr, -- :: DataType -> String  -> Constr+        -- ** Observers+        constrType,     -- :: Constr   -> DataType+        ConstrRep(..),  -- instance of: Eq, Show+        constrRep,      -- :: Constr   -> ConstrRep+        constrFields,   -- :: Constr   -> [String]+        constrFixity,   -- :: Constr   -> Fixity+        -- ** Convenience function: algebraic data types+        constrIndex,    -- :: Constr   -> ConIndex+        -- ** From strings to constructors and vice versa: all data types+        showConstr,     -- :: Constr   -> String+        readConstr,     -- :: DataType -> String -> Maybe Constr++        -- * Convenience functions: take type constructors apart+        tyconUQname,    -- :: String -> String+        tyconModule,    -- :: String -> String++        -- * Generic operations defined in terms of 'gunfold'+        fromConstr,     -- :: Constr -> a+        fromConstrB,    -- :: ... -> Constr -> a+        fromConstrM     -- :: Monad m => ... -> Constr -> m a++  ) where+++------------------------------------------------------------------------------++import Prelude -- necessary to get dependencies right++import Data.Typeable+import Data.Maybe+import Control.Monad++-- Imports for the instances+import Data.Typeable+import Data.Int              -- So we can give Data instance for Int8, ...+import Data.Word             -- So we can give Data instance for Word8, ...+#ifdef __GLASGOW_HASKELL__+import GHC.Real( Ratio(..) ) -- 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 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+#else+# ifdef __HUGS__+import Hugs.Prelude( Ratio(..) )+# endif+import System.IO+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Control.Monad.ST+import Control.Concurrent+import Data.Array+import Data.IORef+#endif++#include "Typeable.h"++++------------------------------------------------------------------------------+--+--      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 withing 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 @T a@, 'dataCast1' should be defined+  -- as 'gcast1'.+  --+  -- The default definition is @'const' 'Nothing'@, which is appropriate+  -- for non-unary type constructors.+  dataCast1 :: Typeable1 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 @T a b@, 'dataCast2' should be+  -- defined as 'gcast2'.+  --+  -- The default definition is @'const' 'Nothing'@, which is appropriate+  -- for non-binary type constructors.+  dataCast2 :: Typeable2 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 an identity datatype constructor ID (see below)+  -- to instantiate the type constructor c in the type of gfoldl,+  -- and perform injections ID and projections unID accordingly.+  --+  gmapT f x0 = unID (gfoldl k ID x0)+    where+      k (ID c) x = ID (c (f x))+++  -- | A generic query with a left-associative binary operator+  gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r+  gmapQl o r f = unCONST . gfoldl k z+    where+      k c x = CONST $ (unCONST c) `o` f x+      z _   = CONST r++  -- | A generic query with a right-associative binary operator+  gmapQr :: (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 (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 declaratoin 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 :: 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 (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q)+      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   :: 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 c x = do c' <- c+                 x' <- f x+                 return (c' x')+++  -- | Transformation of at least one immediate subterm does not fail+  gmapMp :: 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 (return (g,False))+      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 :: 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 (return (g,False))+      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)+             )+++-- | The identity type constructor needed for the definition of gmapT+newtype ID x = ID { unID :: x }+++-- | The constant type constructor needed for the definition of gmapQl+newtype CONST c a = CONST { unCONST :: c }+++-- | 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 undefined+++-- | Build a term and use a generic function for subterms+fromConstrB :: Data a+            => (forall d. Data d => d)+            -> Constr+            -> a+fromConstrB f = unID . gunfold k z+ where+  k c = ID (unID c f)+  z = ID+++-- | Monadic variation on 'fromConstrB'+fromConstrM :: (Monad m, Data a)+            => (forall d. Data d => m d)+            -> Constr+            -> m a+fromConstrM f = gunfold k z+ where+  k c = do { c' <- c; b <- f; return (c' b) }+  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+++-- | Representation of constructors+data Constr = Constr+                        { conrep    :: ConstrRep+                        , constring :: String+                        , confields :: [String] -- for AlgRep only+                        , confixity :: Fixity   -- for AlgRep only+                        , datatype  :: DataType+                        }++instance Show Constr where+ show = constring+++-- | Equality of constructors+instance Eq Constr where+  c == c' = constrRep c == constrRep c'+++-- | Public representation of datatypes+data DataRep = AlgRep [Constr]+             | IntRep+             | FloatRep+             | StringRep+             | NoRep++            deriving (Eq,Show)+-- The list of constructors could be an array, a balanced tree, or others.+++-- | Public representation of constructors+data ConstrRep = AlgConstr    ConIndex+               | IntConstr    Integer+               | FloatConstr  Double+               | StringConstr String++               deriving (Eq,Show)+++-- | 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,Show)+++------------------------------------------------------------------------------+--+--      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)      -> mkIntConstr dt i+        (FloatRep,  FloatConstr f)    -> mkFloatConstr dt f+        (StringRep, StringConstr str) -> mkStringConstr dt str+        _ -> error "repConstr"++++------------------------------------------------------------------------------+--+--      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+mkConstr :: DataType -> String -> [String] -> Fixity -> Constr+mkConstr dt str fields fix =+        Constr+                { conrep    = AlgConstr idx+                , constring = str+                , confields = fields+                , confixity = fix+                , datatype  = dt+                }+  where+    idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],+                     showConstr c == str ]+++-- | Gets the constructors of an algebraic datatype+dataTypeConstrs :: DataType -> [Constr]+dataTypeConstrs dt = case datarep dt of+                        (AlgRep cons) -> cons+                        _ -> error "dataTypeConstrs"+++-- | 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 (\f -> (mkPrimCon dt str (FloatConstr f)))+        StringRep   -> Just (mkStringConstr dt str)+        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)+++------------------------------------------------------------------------------+--+--      Convenience funtions: 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)+                        _           -> error "indexConstr"+++-- | Gets the index of a constructor (algebraic datatypes only)+constrIndex :: Constr -> ConIndex+constrIndex con = case constrRep con of+                    (AlgConstr idx) -> idx+                    _ -> error "constrIndex"+++-- | Gets the maximum constructor index of an algebraic datatype+maxConstrIndex :: DataType -> ConIndex+maxConstrIndex dt = case dataTypeRep dt of+                        AlgRep cs -> length cs+                        _            -> error "maxConstrIndex"++++------------------------------------------------------------------------------+--+--      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 'String' type+mkStringType :: String -> DataType+mkStringType = mkPrimType StringRep+++-- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType'+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 = error "constrFields"+                        , confixity = error "constrFixity"+                        }+++mkIntConstr :: DataType -> Integer -> Constr+mkIntConstr dt i = case datarep dt of+                  IntRep -> mkPrimCon dt (show i) (IntConstr i)+                  _ -> error "mkIntConstr"+++mkFloatConstr :: DataType -> Double -> Constr+mkFloatConstr dt f = case datarep dt of+                    FloatRep -> mkPrimCon dt (show f) (FloatConstr f)+                    _ -> error "mkFloatConstr"+++mkStringConstr :: DataType -> String -> Constr+mkStringConstr dt str = case datarep dt of+                       StringRep -> mkPrimCon dt str (StringConstr str)+                       _ -> error "mkStringConstr"+++------------------------------------------------------------------------------+--+--      Non-representations for non-presentable types+--+------------------------------------------------------------------------------+++-- | Constructs a non-representation for a non-presentable 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.+--+------------------------------------------------------------------------------+++falseConstr :: Constr+falseConstr  = mkConstr boolDataType "False" [] Prefix+trueConstr :: Constr+trueConstr   = mkConstr boolDataType "True"  [] Prefix++boolDataType :: DataType+boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr]++instance Data Bool where+  toConstr False = falseConstr+  toConstr True  = trueConstr+  gunfold _ z c  = case constrIndex c of+                     1 -> z False+                     2 -> z True+                     _ -> error "gunfold"+  dataTypeOf _ = boolDataType+++------------------------------------------------------------------------------++charType :: DataType+charType = mkStringType "Prelude.Char"++instance Data Char where+  toConstr x = mkStringConstr charType [x]+  gunfold _ z c = case constrRep c of+                    (StringConstr [x]) -> z x+                    _ -> error "gunfold"+  dataTypeOf _ = charType+++------------------------------------------------------------------------------++floatType :: DataType+floatType = mkFloatType "Prelude.Float"++instance Data Float where+  toConstr x = mkFloatConstr floatType (realToFrac x)+  gunfold _ z c = case constrRep c of+                    (FloatConstr x) -> z (realToFrac x)+                    _ -> error "gunfold"+  dataTypeOf _ = floatType+++------------------------------------------------------------------------------++doubleType :: DataType+doubleType = mkFloatType "Prelude.Double"++instance Data Double where+  toConstr = mkFloatConstr floatType+  gunfold _ z c = case constrRep c of+                    (FloatConstr x) -> z x+                    _ -> error "gunfold"+  dataTypeOf _ = doubleType+++------------------------------------------------------------------------------++intType :: DataType+intType = mkIntType "Prelude.Int"++instance Data Int where+  toConstr x = mkIntConstr intType (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = intType+++------------------------------------------------------------------------------++integerType :: DataType+integerType = mkIntType "Prelude.Integer"++instance Data Integer where+  toConstr = mkIntConstr integerType+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z x+                    _ -> error "gunfold"+  dataTypeOf _ = integerType+++------------------------------------------------------------------------------++int8Type :: DataType+int8Type = mkIntType "Data.Int.Int8"++instance Data Int8 where+  toConstr x = mkIntConstr int8Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = int8Type+++------------------------------------------------------------------------------++int16Type :: DataType+int16Type = mkIntType "Data.Int.Int16"++instance Data Int16 where+  toConstr x = mkIntConstr int16Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = int16Type+++------------------------------------------------------------------------------++int32Type :: DataType+int32Type = mkIntType "Data.Int.Int32"++instance Data Int32 where+  toConstr x = mkIntConstr int32Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = int32Type+++------------------------------------------------------------------------------++int64Type :: DataType+int64Type = mkIntType "Data.Int.Int64"++instance Data Int64 where+  toConstr x = mkIntConstr int64Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = int64Type+++------------------------------------------------------------------------------++wordType :: DataType+wordType = mkIntType "Data.Word.Word"++instance Data Word where+  toConstr x = mkIntConstr wordType (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = wordType+++------------------------------------------------------------------------------++word8Type :: DataType+word8Type = mkIntType "Data.Word.Word8"++instance Data Word8 where+  toConstr x = mkIntConstr word8Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = word8Type+++------------------------------------------------------------------------------++word16Type :: DataType+word16Type = mkIntType "Data.Word.Word16"++instance Data Word16 where+  toConstr x = mkIntConstr word16Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = word16Type+++------------------------------------------------------------------------------++word32Type :: DataType+word32Type = mkIntType "Data.Word.Word32"++instance Data Word32 where+  toConstr x = mkIntConstr word32Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = word32Type+++------------------------------------------------------------------------------++word64Type :: DataType+word64Type = mkIntType "Data.Word.Word64"++instance Data Word64 where+  toConstr x = mkIntConstr word64Type (fromIntegral x)+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error "gunfold"+  dataTypeOf _ = word64Type+++------------------------------------------------------------------------------++ratioConstr :: Constr+ratioConstr = mkConstr ratioDataType ":%" [] Infix++ratioDataType :: DataType+ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr]++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 _ _ _ = error "gunfold"+  dataTypeOf _  = ratioDataType+++------------------------------------------------------------------------------++nilConstr :: Constr+nilConstr    = mkConstr listDataType "[]" [] Prefix+consConstr :: Constr+consConstr   = mkConstr listDataType "(:)" [] Infix++listDataType :: DataType+listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]++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 (:)))+                    _ -> error "gunfold"+  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')+++------------------------------------------------------------------------------++nothingConstr :: Constr+nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix+justConstr :: Constr+justConstr    = mkConstr maybeDataType "Just"    [] Prefix++maybeDataType :: DataType+maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr]++instance Data a => Data (Maybe a) where+  gfoldl _ z Nothing  = z Nothing+  gfoldl f z (Just x) = z Just `f` x+  toConstr Nothing  = nothingConstr+  toConstr (Just _) = justConstr+  gunfold k z c = case constrIndex c of+                    1 -> z Nothing+                    2 -> k (z Just)+                    _ -> error "gunfold"+  dataTypeOf _ = maybeDataType+  dataCast1 f  = gcast1 f+++------------------------------------------------------------------------------++ltConstr :: Constr+ltConstr         = mkConstr orderingDataType "LT" [] Prefix+eqConstr :: Constr+eqConstr         = mkConstr orderingDataType "EQ" [] Prefix+gtConstr :: Constr+gtConstr         = mkConstr orderingDataType "GT" [] Prefix++orderingDataType :: DataType+orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr]++instance Data Ordering where+  gfoldl _ z LT  = z LT+  gfoldl _ z EQ  = z EQ+  gfoldl _ z GT  = z GT+  toConstr LT  = ltConstr+  toConstr EQ  = eqConstr+  toConstr GT  = gtConstr+  gunfold _ z c = case constrIndex c of+                    1 -> z LT+                    2 -> z EQ+                    3 -> z GT+                    _ -> error "gunfold"+  dataTypeOf _ = orderingDataType+++------------------------------------------------------------------------------++leftConstr :: Constr+leftConstr     = mkConstr eitherDataType "Left"  [] Prefix++rightConstr :: Constr+rightConstr    = mkConstr eitherDataType "Right" [] Prefix++eitherDataType :: DataType+eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr]++instance (Data a, Data b) => Data (Either a b) where+  gfoldl f z (Left a)   = z Left  `f` a+  gfoldl f z (Right a)  = z Right `f` a+  toConstr (Left _)  = leftConstr+  toConstr (Right _) = rightConstr+  gunfold k z c = case constrIndex c of+                    1 -> k (z Left)+                    2 -> k (z Right)+                    _ -> error "gunfold"+  dataTypeOf _ = eitherDataType+  dataCast2 f  = gcast2 f+++------------------------------------------------------------------------------++tuple0Constr :: Constr+tuple0Constr = mkConstr tuple0DataType "()" [] Prefix++tuple0DataType :: DataType+tuple0DataType = mkDataType "Prelude.()" [tuple0Constr]++instance Data () where+  toConstr ()   = tuple0Constr+  gunfold _ z c | constrIndex c == 1 = z ()+  gunfold _ _ _ = error "gunfold"+  dataTypeOf _  = tuple0DataType+++------------------------------------------------------------------------------++tuple2Constr :: Constr+tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix++tuple2DataType :: DataType+tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr]++instance (Data a, Data b) => Data (a,b) where+  gfoldl f z (a,b) = z (,) `f` a `f` b+  toConstr (_,_) = tuple2Constr+  gunfold k z c | constrIndex c == 1 = k (k (z (,)))+  gunfold _ _ _ = error "gunfold"+  dataTypeOf _  = tuple2DataType+  dataCast2 f   = gcast2 f+++------------------------------------------------------------------------------++tuple3Constr :: Constr+tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix++tuple3DataType :: DataType+tuple3DataType = mkDataType "Prelude.(,)" [tuple3Constr]++instance (Data a, Data b, Data c) => Data (a,b,c) where+  gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c+  toConstr (_,_,_) = tuple3Constr+  gunfold k z c | constrIndex c == 1 = k (k (k (z (,,))))+  gunfold _ _ _ = error "gunfold"+  dataTypeOf _  = tuple3DataType+++------------------------------------------------------------------------------++tuple4Constr :: Constr+tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix++tuple4DataType :: DataType+tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr]++instance (Data a, Data b, Data c, Data d)+         => Data (a,b,c,d) where+  gfoldl f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d+  toConstr (_,_,_,_) = tuple4Constr+  gunfold k z c = case constrIndex c of+                    1 -> k (k (k (k (z (,,,)))))+                    _ -> error "gunfold"+  dataTypeOf _ = tuple4DataType+++------------------------------------------------------------------------------++tuple5Constr :: Constr+tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix++tuple5DataType :: DataType+tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr]++instance (Data a, Data b, Data c, Data d, Data e)+         => Data (a,b,c,d,e) where+  gfoldl f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e+  toConstr (_,_,_,_,_) = tuple5Constr+  gunfold k z c = case constrIndex c of+                    1 -> k (k (k (k (k (z (,,,,))))))+                    _ -> error "gunfold"+  dataTypeOf _ = tuple5DataType+++------------------------------------------------------------------------------++tuple6Constr :: Constr+tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix++tuple6DataType :: DataType+tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr]++instance (Data a, Data b, Data c, Data d, Data e, Data f)+         => Data (a,b,c,d,e,f) where+  gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f'+  toConstr (_,_,_,_,_,_) = tuple6Constr+  gunfold k z c = case constrIndex c of+                    1 -> k (k (k (k (k (k (z (,,,,,)))))))+                    _ -> error "gunfold"+  dataTypeOf _ = tuple6DataType+++------------------------------------------------------------------------------++tuple7Constr :: Constr+tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix++tuple7DataType :: DataType+tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr]++instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g)+         => Data (a,b,c,d,e,f,g) where+  gfoldl f z (a,b,c,d,e,f',g) =+    z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g+  toConstr  (_,_,_,_,_,_,_) = tuple7Constr+  gunfold k z c = case constrIndex c of+                    1 -> k (k (k (k (k (k (k (z (,,,,,,))))))))+                    _ -> error "gunfold"+  dataTypeOf _ = tuple7DataType+++------------------------------------------------------------------------------++instance Typeable a => Data (Ptr a) where+  toConstr _   = error "toConstr"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNorepType "GHC.Ptr.Ptr"+++------------------------------------------------------------------------------++instance Typeable a => Data (ForeignPtr a) where+  toConstr _   = error "toConstr"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNorepType "GHC.ForeignPtr.ForeignPtr"+++------------------------------------------------------------------------------+-- The Data instance for Array preserves data abstraction at the cost of +-- inefficiency. We omit reflection services for the sake of data abstraction.+instance (Typeable a, Data b, Ix a) => Data (Array a b)+ where+  gfoldl f z a = z (listArray (bounds a)) `f` (elems a)+  toConstr _   = error "toConstr"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNorepType "Data.Array.Array"+
Data/Dynamic.hs view
@@ -1,2 +1,161 @@-module Data.Dynamic (module X___) where-import "base" Data.Dynamic as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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+  (++        -- Module Data.Typeable re-exported for convenience+        module Data.Typeable,++        -- * The @Dynamic@ type+        Dynamic,        -- abstract, instance of: Show, Typeable++        -- * Converting to and from @Dynamic@+        toDyn,          -- :: Typeable a => a -> Dynamic+        fromDyn,        -- :: Typeable a => Dynamic -> a -> a+        fromDynamic,    -- :: Typeable a => Dynamic -> Maybe a+        +        -- * Applying functions of dynamic type+        dynApply,+        dynApp,+        dynTypeRep++  ) where+++import Data.Typeable+import Data.Maybe+import Unsafe.Coerce++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Show+import GHC.Err+import GHC.Num+#endif++#ifdef __HUGS__+import Hugs.Prelude+import Hugs.IO+import Hugs.IORef+import Hugs.IOExts+#endif++#ifdef __NHC__+import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)+#endif++#include "Typeable.h"++-------------------------------------------------------------+--+--              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.+-}+#ifndef __HUGS__+data Dynamic = Dynamic TypeRep Obj+#endif++INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")++instance Show Dynamic where+   -- the instance just prints the type representation.+   showsPrec _ (Dynamic t _) = +          showString "<<" . +          showsPrec 0 t   . +          showString ">>"++#ifdef __GLASGOW_HASKELL__+type Obj = Any+ -- 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.+#elif !defined(__HUGS__)+data Obj = Obj+#endif++-- | 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 (typeOf v) (unsafeCoerce 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+  | typeOf def == t = unsafeCoerce v+  | otherwise       = def++-- | Converts a 'Dynamic' object back into an ordinary Haskell value of+-- the correct type.  See also 'fromDyn'.+fromDynamic+        :: 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) =+  case unsafeCoerce v of +    r | t == typeOf r -> Just r+      | otherwise     -> Nothing++-- (f::(a->b)) `dynApply` (x::a) = (f a)::b+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic+dynApply (Dynamic t1 f) (Dynamic t2 x) =+  case funResultTy t1 t2 of+    Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))+    Nothing -> Nothing++dynApp :: Dynamic -> Dynamic -> Dynamic+dynApp f x = case dynApply f x of +             Just r -> r+             Nothing -> error ("Type error in dynamic application.\n" +++                               "Can't apply function " ++ show f +++                               " to argument " ++ show x)++dynTypeRep :: Dynamic -> TypeRep+dynTypeRep (Dynamic tr _) = tr
Data/Either.hs view
@@ -1,2 +1,93 @@-module Data.Either (module X___) where-import "base" Data.Either as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,           -- :: (a -> c) -> (b -> c) -> Either a b -> c+   lefts,            -- :: [Either a b] -> [a]+   rights,           -- :: [Either a b] -> [b]+   partitionEithers, -- :: [Either a b] -> ([a],[b])+ ) where++#include "Typeable.h"++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Show+import GHC.Read+#endif++import Data.Typeable++#ifdef __GLASGOW_HASKELL__+{-+-- 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\").+-}+data  Either a b  =  Left a | Right b   deriving (Eq, Ord, Read, Show)++-- | 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@.+either                  :: (a -> c) -> (b -> c) -> Either a b -> c+either f _ (Left x)     =  f x+either _ g (Right y)    =  g y+#endif  /* __GLASGOW_HASKELL__ */++INSTANCE_TYPEABLE2(Either,eitherTc,"Either")++-- | Extracts from a list of 'Either' all the 'Left' elements+-- All the 'Left' elements are extracted in order.++lefts   :: [Either a b] -> [a]+lefts x = [a | Left a <- x]++-- | Extracts from a list of 'Either' all the 'Right' elements+-- All the 'Right' elements are extracted in order.++rights   :: [Either a b] -> [b]+rights x = [a | Right a <- x]++-- | 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.++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)++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+prop_partitionEithers :: [Either Int Int] -> Bool+prop_partitionEithers x =+  partitionEithers x == (lefts x, rights x)+-}+
Data/Eq.hs view
@@ -1,2 +1,22 @@-module Data.Eq (module X___) where-import "base" Data.Eq as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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++#if __GLASGOW_HASKELL__+import GHC.Base+#endif
Data/Fixed.hs view
@@ -1,2 +1,147 @@-module Data.Fixed (module X___) where-import "base" Data.Fixed as X___+{-# OPTIONS -Wall -fno-warn-unused-binds #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Fixed+-- Copyright   :  (c) Ashley Yakeley 2005, 2006+-- 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.+-- Parameter types E6 and E12 (for 10^6 and 10^12) are defined, as well as+-- type synonyms for Fixed E6 and Fixed E12.+--+-- 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,+        E6,Micro,+        E12,Pico+) where++import Prelude -- necessary to get dependencies right++-- | 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++newtype Fixed a = MkFixed Integer deriving (Eq,Ord)++class HasResolution a where+        resolution :: a -> Integer++fixedResolution :: (HasResolution a) => Fixed a -> Integer+fixedResolution fa = resolution (uf fa) where+        uf :: Fixed a -> a+        uf _ = undefined++withType :: (a -> f a) -> f a+withType foo = foo undefined++withResolution :: (HasResolution a) => (Integer -> f a) -> f a+withResolution foo = withType (foo . resolution)++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)++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) (fixedResolution 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))++instance (HasResolution a) => Real (Fixed a) where+        toRational fa@(MkFixed a) = (toRational a) / (toRational (fixedResolution fa))++instance (HasResolution a) => Fractional (Fixed a) where+        fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (fixedResolution fa)) b)+        recip fa@(MkFixed a) = MkFixed (div (res * res) a) where+                res = fixedResolution fa+        fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))++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 = fixedResolution fa+        (i,d) = divMod a res+        -- enough digits to be unambiguous+        digits = ceiling (logBase 10 (fromInteger res) :: Double)+        maxnum = 10 ^ digits+        fracNum = div (d * maxnum) res++instance (HasResolution a) => Show (Fixed a) where+        show = showFixed False++++data E6 = E6++instance HasResolution E6 where+        resolution _ = 1000000++type Micro = Fixed E6+++data E12 = E12++instance HasResolution E12 where+        resolution _ = 1000000000000++type Pico = Fixed E12
Data/Foldable.hs view
@@ -1,2 +1,308 @@-module Data.Foldable (module X___) where-import "base" Data.Foldable as X___+-----------------------------------------------------------------------------+-- |+-- 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.+--+-- Many of these functions generalize "Prelude", "Control.Monad" and+-- "Data.List" functions of the same names from lists to any 'Foldable'+-- functor.  To avoid ambiguity, either import those modules hiding+-- these names or qualify uses of these function names with an alias+-- for this module.++module Data.Foldable (+        -- * Folds+        Foldable(..),+        -- ** Special biased folds+        foldr',+        foldl',+        foldrM,+        foldlM,+        -- ** Folding actions+        -- *** Applicative actions+        traverse_,+        for_,+        sequenceA_,+        asum,+        -- *** Monadic actions+        mapM_,+        forM_,+        sequence_,+        msum,+        -- ** Specialized folds+        toList,+        concat,+        concatMap,+        and,+        or,+        any,+        all,+        sum,+        product,+        maximum,+        maximumBy,+        minimum,+        minimumBy,+        -- ** Searches+        elem,+        notElem,+        find+        ) where++import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_,+                elem, notElem, concat, concatMap, and, or, any, all,+                sum, product, maximum, minimum)+import qualified Prelude (foldl, foldr, foldl1, foldr1)+import Control.Applicative+import Control.Monad (MonadPlus(..))+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Monoid++#ifdef __NHC__+import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build)+#endif++#if defined(__GLASGOW_HASKELL__)+import GHC.Arr+#elif defined(__HUGS__)+import Hugs.Array+#elif defined(__NHC__)+import Array+#endif++-- | Data structures that can be folded.+--+-- Minimal complete definition: 'foldMap' or 'foldr'.+--+-- For example, given a data type+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be+--+-- > instance Foldable Tree+-- >    foldMap f Empty = mempty+-- >    foldMap f (Leaf x) = f x+-- >    foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r+--+-- This is suitable even for abstract types, as the monoid is assumed+-- to satisfy the monoid laws.+--+class Foldable t where+        -- | Combine the elements of a structure using a monoid.+        fold :: Monoid m => t m -> m+        fold = foldMap id++        -- | Map each element of the structure to a monoid,+        -- and combine the results.+        foldMap :: Monoid m => (a -> m) -> t a -> m+        foldMap f = foldr (mappend . f) mempty++        -- | Right-associative fold of a structure.+        --+        -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@+        foldr :: (a -> b -> b) -> b -> t a -> b+        foldr f z t = appEndo (foldMap (Endo . f) t) z++        -- | Left-associative fold of a structure.+        --+        -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@+        foldl :: (a -> b -> a) -> a -> t b -> a+        foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z++        -- | A variant of 'foldr' that has no base case,+        -- and thus may only be applied to non-empty structures.+        --+        -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@+        foldr1 :: (a -> a -> a) -> t a -> a+        foldr1 f xs = fromMaybe (error "foldr1: empty structure")+                        (foldr mf Nothing xs)+          where mf x Nothing = Just x+                mf x (Just y) = Just (f x y)++        -- | A variant of 'foldl' that has no base case,+        -- and thus may only be applied to non-empty structures.+        --+        -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@+        foldl1 :: (a -> a -> a) -> t a -> a+        foldl1 f xs = fromMaybe (error "foldl1: empty structure")+                        (foldl mf Nothing xs)+          where mf Nothing y = Just y+                mf (Just x) y = Just (f x y)++-- instances for Prelude types++instance Foldable Maybe where+        foldr _ z Nothing = z+        foldr f z (Just x) = f x z++        foldl _ z Nothing = z+        foldl f z (Just x) = f z x++instance Foldable [] where+        foldr = Prelude.foldr+        foldl = Prelude.foldl+        foldr1 = Prelude.foldr1+        foldl1 = Prelude.foldl1++instance Ix i => Foldable (Array i) where+        foldr f z = Prelude.foldr f z . elems++-- | Fold over the elements of a structure,+-- associating to the right, but strictly.+foldr' :: Foldable t => (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++-- | Monadic fold over the elements of a structure,+-- associating to the right, i.e. from right to left.+foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b+foldrM f z0 xs = foldl f' return xs z0+  where f' k x z = f x z >>= k++-- | Fold over the elements of a structure,+-- associating to the left, but strictly.+foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a+foldl' f z0 xs = foldr f' id xs z0+  where f' x k z = k $! f z x++-- | Monadic fold over the elements of a structure,+-- associating to the left, i.e. from left to right.+foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a+foldlM f z0 xs = foldr f' return xs z0+  where f' x k z = f z x >>= k++-- | Map each element of a structure to an action, evaluate+-- these actions from left to right, and ignore the results.+traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()+traverse_ f = foldr ((*>) . f) (pure ())++-- | 'for_' is 'traverse_' with its arguments flipped.+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.+mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()+mapM_ f = foldr ((>>) . f) (return ())++-- | 'forM_' is 'mapM_' with its arguments flipped.+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.+sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()+sequenceA_ = foldr (*>) (pure ())++-- | Evaluate each monadic action in the structure from left to right,+-- and ignore the results.+sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()+sequence_ = foldr (>>) (return ())++-- | The sum of a collection of actions, generalizing 'concat'.+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 :: (Foldable t, MonadPlus m) => t (m a) -> m a+{-# INLINE msum #-}+msum = foldr mplus mzero++-- These use foldr rather than foldMap to avoid repeated concatenation.++-- | List of elements of a structure.+toList :: Foldable t => t a -> [a]+#ifdef __GLASGOW_HASKELL__+toList t = build (\ c n -> foldr c n t)+#else+toList = foldr (:) []+#endif++-- | The concatenation of all the elements of a container of lists.+concat :: Foldable t => t [a] -> [a]+concat = fold++-- | Map a function over all the elements of a container and concatenate+-- the resulting lists.+concatMap :: Foldable t => (a -> [b]) -> t a -> [b]+concatMap = foldMap++-- | '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.+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.+or :: Foldable t => t Bool -> Bool+or = getAny . foldMap Any++-- | Determines whether any element of the structure satisfies the predicate.+any :: Foldable t => (a -> Bool) -> t a -> Bool+any p = getAny . foldMap (Any . p)++-- | Determines whether all elements of the structure satisfy the predicate.+all :: Foldable t => (a -> Bool) -> t a -> Bool+all p = getAll . foldMap (All . p)++-- | The 'sum' function computes the sum of the numbers of a structure.+sum :: (Foldable t, Num a) => t a -> a+sum = getSum . foldMap Sum++-- | The 'product' function computes the product of the numbers of a structure.+product :: (Foldable t, Num a) => t a -> a+product = getProduct . foldMap Product++-- | The largest element of a non-empty structure.+maximum :: (Foldable t, Ord a) => t a -> a+maximum = foldr1 max++-- | The largest element of a non-empty structure with respect to the+-- given comparison function.+maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a+maximumBy cmp = foldr1 max'+  where max' x y = case cmp x y of+                        GT -> x+                        _  -> y++-- | The least element of a non-empty structure.+minimum :: (Foldable t, Ord a) => t a -> a+minimum = foldr1 min++-- | The least element of a non-empty structure with respect to the+-- given comparison function.+minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a+minimumBy cmp = foldr1 min'+  where min' x y = case cmp x y of+                        GT -> y+                        _  -> x++-- | Does the element occur in the structure?+elem :: (Foldable t, Eq a) => a -> t a -> Bool+elem = any . (==)++-- | 'notElem' is the negation of 'elem'.+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.+find :: Foldable t => (a -> Bool) -> t a -> Maybe a+find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])
Data/Function.hs view
@@ -1,2 +1,83 @@-module Data.Function (module X___) where-import "base" Data.Function as X___+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Function+-- Copyright   :  Nils Anders Danielsson 2006+-- 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 Prelude++infixl 0 `on`++-- | @'fix' f@ is the least fixed point of the function @f@,+-- i.e. the least defined @x@ such that @f x = x@.+fix :: (a -> a) -> a+fix f = let x = f x in x++-- | @(*) \`on\` f = \\x y -> f x * f y@.+--+-- Typical usage: @'Data.List.sortBy' ('compare' \`on\` '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)@++-- 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)++on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+(.*.) `on` f = \x y -> f x .*. f y
− Data/Generics.hs 
@@ -1,2 +0,0 @@-module Data.Generics (module X___) where-import "syb" Data.Generics as X___
− Data/Generics/Aliases.hs 
@@ -1,2 +0,0 @@-module Data.Generics.Aliases (module X___) where-import "syb" Data.Generics.Aliases as X___
− Data/Generics/Basics.hs 
@@ -1,2 +0,0 @@-module Data.Generics.Basics (module X___) where-import "syb" Data.Generics.Basics as X___
− Data/Generics/Instances.hs 
@@ -1,2 +0,0 @@-module Data.Generics.Instances () where-import "syb" Data.Generics.Instances as X___ ()
− Data/Generics/Schemes.hs 
@@ -1,2 +0,0 @@-module Data.Generics.Schemes (module X___) where-import "syb" Data.Generics.Schemes as X___
− Data/Generics/Text.hs 
@@ -1,2 +0,0 @@-module Data.Generics.Text (module X___) where-import "syb" Data.Generics.Text as X___
− Data/Generics/Twins.hs 
@@ -1,2 +0,0 @@-module Data.Generics.Twins (module X___) where-import "syb" Data.Generics.Twins as X___
Data/HashTable.hs view
@@ -1,2 +1,498 @@-module Data.HashTable (module X___) where-import "base" Data.HashTable as X___+{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.HashTable+-- Copyright   :  (c) The University of Glasgow 2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- An implementation of extensible hash tables, as described in+-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988,+-- pp. 446--457.  The implementation is also derived from the one+-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@).+--+-----------------------------------------------------------------------------++module Data.HashTable (+        -- * Basic hash table operations+        HashTable, new, insert, delete, lookup, update,+        -- * Converting to and from lists+        fromList, toList,+        -- * Hash functions+        -- $hash_functions+        hashInt, hashString,+        prime,+        -- * Diagnostics+        longestChain+ ) where++-- This module is imported by Data.Dynamic, which is pretty low down in the+-- module hierarchy, so don't import "high-level" modules++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#else+import Prelude  hiding  ( lookup )+#endif+import Data.Tuple       ( fst )+import Data.Bits+import Data.Maybe+import Data.List        ( maximumBy, length, concat, foldl', partition )+import Data.Int         ( Int32 )++#if defined(__GLASGOW_HASKELL__)+import GHC.Num+import GHC.Real         ( fromIntegral )+import GHC.Show         ( Show(..) )+import GHC.Int          ( Int64 )++import GHC.IOBase       ( IO, IOArray, newIOArray,+                          unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO,+                          IORef, newIORef, readIORef, writeIORef )+#else+import Data.Char        ( ord )+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )+import System.IO.Unsafe ( unsafePerformIO )+import Data.Int         ( Int64 )+#  if defined(__HUGS__)+import Hugs.IOArray     ( IOArray, newIOArray,+                          unsafeReadIOArray, unsafeWriteIOArray )+#  elif defined(__NHC__)+import NHC.IOExtras     ( IOArray, newIOArray, readIOArray, writeIOArray )+#  endif+#endif+import Control.Monad    ( mapM, mapM_, sequence_ )+++-----------------------------------------------------------------------++iNSTRUMENTED :: Bool+iNSTRUMENTED = False++-----------------------------------------------------------------------++readHTArray  :: HTArray a -> Int32 -> IO a+writeMutArray :: MutArray a -> Int32 -> a -> IO ()+freezeArray  :: MutArray a -> IO (HTArray a)+thawArray    :: HTArray a -> IO (MutArray a)+newMutArray   :: (Int32, Int32) -> a -> IO (MutArray a)+#if defined(DEBUG) || defined(__NHC__)+type MutArray a = IOArray Int32 a+type HTArray a = MutArray a+newMutArray = newIOArray+readHTArray  = readIOArray+writeMutArray = writeIOArray+freezeArray = return+thawArray = return+#else+type MutArray a = IOArray Int32 a+type HTArray a = MutArray a -- Array Int32 a+newMutArray = newIOArray+readHTArray arr i = readMutArray arr i -- return $! (unsafeAt arr (fromIntegral i))+readMutArray  :: MutArray a -> Int32 -> IO a+readMutArray arr i = unsafeReadIOArray arr (fromIntegral i)+writeMutArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x+freezeArray = return -- unsafeFreeze+thawArray = return -- unsafeThaw+#endif++data HashTable key val = HashTable {+                                     cmp     :: !(key -> key -> Bool),+                                     hash_fn :: !(key -> Int32),+                                     tab     :: !(IORef (HT key val))+                                   }+-- TODO: the IORef should really be an MVar.++data HT key val+  = HT {+        kcount  :: !Int32,              -- Total number of keys.+        bmask   :: !Int32,+        buckets :: !(HTArray [(key,val)])+       }++-- ------------------------------------------------------------+-- Instrumentation for performance tuning++-- This ought to be roundly ignored after optimization when+-- iNSTRUMENTED=False.++-- STRICT version of modifyIORef!+modifyIORef :: IORef a -> (a -> a) -> IO ()+modifyIORef r f = do+  v <- readIORef r+  let z = f v in z `seq` writeIORef r z++data HashData = HD {+  tables :: !Integer,+  insertions :: !Integer,+  lookups :: !Integer,+  totBuckets :: !Integer,+  maxEntries :: !Int32,+  maxChain :: !Int,+  maxBuckets :: !Int32+} deriving (Eq, Show)++{-# NOINLINE hashData #-}+hashData :: IORef HashData+hashData =  unsafePerformIO (newIORef (HD { tables=0, insertions=0, lookups=0,+                                            totBuckets=0, maxEntries=0,+                                            maxChain=0, maxBuckets=tABLE_MIN } ))++instrument :: (HashData -> HashData) -> IO ()+instrument i | iNSTRUMENTED = modifyIORef hashData i+             | otherwise    = return ()++recordNew :: IO ()+recordNew = instrument rec+  where rec hd@HD{ tables=t, totBuckets=b } =+               hd{ tables=t+1, totBuckets=b+fromIntegral tABLE_MIN }++recordIns :: Int32 -> Int32 -> [a] -> IO ()+recordIns i sz bkt = instrument rec+  where rec hd@HD{ insertions=ins, maxEntries=mx, maxChain=mc } =+               hd{ insertions=ins+fromIntegral i, maxEntries=mx `max` sz,+                   maxChain=mc `max` length bkt }++recordResize :: Int32 -> Int32 -> IO ()+recordResize older newer = instrument rec+  where rec hd@HD{ totBuckets=b, maxBuckets=mx } =+               hd{ totBuckets=b+fromIntegral (newer-older),+                   maxBuckets=mx `max` newer }++recordLookup :: IO ()+recordLookup = instrument lkup+  where lkup hd@HD{ lookups=l } = hd{ lookups=l+1 }++-- stats :: IO String+-- stats =  fmap show $ readIORef hashData++-- ----------------------------------------------------------------------------+-- Sample hash functions++-- $hash_functions+--+-- This implementation of hash tables uses the low-order /n/ bits of the hash+-- value for a key, where /n/ varies as the hash table grows.  A good hash+-- function therefore will give an even distribution regardless of /n/.+--+-- If your keyspace is integrals such that the low-order bits between+-- keys are highly variable, then you could get away with using 'fromIntegral'+-- as the hash function.+--+-- We provide some sample hash functions for 'Int' and 'String' below.++golden :: Int32+golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32+-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32+-- but that has bad mulHi properties (even adding 2^32 to get its inverse)+-- Whereas the above works well and contains no hash duplications for+-- [-32767..65536]++hashInt32 :: Int32 -> Int32+hashInt32 x = mulHi x golden + x++-- | A sample (and useful) hash function for Int and Int32,+-- implemented by extracting the uppermost 32 bits of the 64-bit+-- result of multiplying by a 33-bit constant.  The constant is from+-- Knuth, derived from the golden ratio:+--+-- > golden = round ((sqrt 5 - 1) * 2^32)+--+-- We get good key uniqueness on small inputs+-- (a problem with previous versions):+--  (length $ group $ sort $ map hashInt [-32767..65536]) == 65536 + 32768+--+hashInt :: Int -> Int32+hashInt x = hashInt32 (fromIntegral x)++-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply+mulHi :: Int32 -> Int32 -> Int32+mulHi a b = fromIntegral (r `shiftR` 32)+   where r :: Int64+         r = fromIntegral a * fromIntegral b++-- | A sample hash function for Strings.  We keep multiplying by the+-- golden ratio and adding.  The implementation is:+--+-- > hashString = foldl' f golden+-- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m+-- >         magic = 0xdeadbeef+--+-- Where hashInt32 works just as hashInt shown above.+--+-- Knuth argues that repeated multiplication by the golden ratio+-- will minimize gaps in the hash space, and thus it's a good choice+-- for combining together multiple keys to form one.+--+-- Here we know that individual characters c are often small, and this+-- produces frequent collisions if we use ord c alone.  A+-- particular problem are the shorter low ASCII and ISO-8859-1+-- character strings.  We pre-multiply by a magic twiddle factor to+-- obtain a good distribution.  In fact, given the following test:+--+-- > testp :: Int32 -> Int+-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls+-- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]+-- >         hs = foldl' f golden+-- >         f m c = fromIntegral (ord c) * k + hashInt32 m+-- >         n = 100000+--+-- We discover that testp magic = 0.++hashString :: String -> Int32+hashString = foldl' f golden+   where f m c = fromIntegral (ord c) * magic + hashInt32 m+         magic = 0xdeadbeef++-- | A prime larger than the maximum hash table size+prime :: Int32+prime = 33554467++-- -----------------------------------------------------------------------------+-- Parameters++tABLE_MAX :: Int32+tABLE_MAX  = 32 * 1024 * 1024   -- Maximum size of hash table+tABLE_MIN :: Int32+tABLE_MIN  = 8++hLOAD :: Int32+hLOAD = 7                       -- Maximum average load of a single hash bucket++hYSTERESIS :: Int32+hYSTERESIS = 64                 -- entries to ignore in load computation++{- Hysteresis favors long association-list-like behavior for small tables. -}++-- -----------------------------------------------------------------------------+-- Creating a new hash table++-- | Creates a new hash table.  The following property should hold for the @eq@+-- and @hash@ functions passed to 'new':+--+-- >   eq A B  =>  hash A == hash B+--+new+  :: (key -> key -> Bool)    -- ^ @eq@: An equality comparison on keys+  -> (key -> Int32)          -- ^ @hash@: A hash function on keys+  -> IO (HashTable key val)  -- ^ Returns: an empty hash table++new cmpr hash = do+  recordNew+  -- make a new hash table with a single, empty, segment+  let mask = tABLE_MIN-1+  bkts'  <- newMutArray (0,mask) []+  bkts   <- freezeArray bkts'++  let+    kcnt = 0+    ht = HT {  buckets=bkts, kcount=kcnt, bmask=mask }++  table <- newIORef ht+  return (HashTable { tab=table, hash_fn=hash, cmp=cmpr })++-- -----------------------------------------------------------------------------+-- Inserting a key\/value pair into the hash table++-- | Inserts a key\/value mapping into the hash table.+--+-- Note that 'insert' doesn't remove the old entry from the table -+-- the behaviour is like an association list, where 'lookup' returns+-- the most-recently-inserted mapping for a key in the table.  The+-- reason for this is to keep 'insert' as efficient as possible.  If+-- you need to update a mapping, then we provide 'update'.+--+insert :: HashTable key val -> key -> val -> IO ()++insert ht key val =+  updatingBucket CanInsert (\bucket -> ((key,val):bucket, 1, ())) ht key+++-- ------------------------------------------------------------+-- The core of the implementation is lurking down here, in findBucket,+-- updatingBucket, and expandHashTable.++tooBig :: Int32 -> Int32 -> Bool+tooBig k b = k-hYSTERESIS > hLOAD * b++-- index of bucket within table.+bucketIndex :: Int32 -> Int32 -> Int32+bucketIndex mask h = h .&. mask++-- find the bucket in which the key belongs.+-- returns (key equality, bucket index, bucket)+--+-- This rather grab-bag approach gives enough power to do pretty much+-- any bucket-finding thing you might want to do.  We rely on inlining+-- to throw away the stuff we don't want.  I'm proud to say that this+-- plus updatingBucket below reduce most of the other definitions to a+-- few lines of code, while actually speeding up the hashtable+-- implementation when compared with a version which does everything+-- from scratch.+{-# INLINE findBucket #-}+findBucket :: HashTable key val -> key -> IO (HT key val, Int32, [(key,val)])+findBucket HashTable{ tab=ref, hash_fn=hash} key = do+  table@HT{ buckets=bkts, bmask=b } <- readIORef ref+  let indx = bucketIndex b (hash key)+  bucket <- readHTArray bkts indx+  return (table, indx, bucket)++data Inserts = CanInsert+             | Can'tInsert+             deriving (Eq)++-- updatingBucket is the real workhorse of all single-element table+-- updates.  It takes a hashtable and a key, along with a function+-- describing what to do with the bucket in which that key belongs.  A+-- flag indicates whether this function may perform table insertions.+-- The function returns the new contents of the bucket, the number of+-- bucket entries inserted (negative if entries were deleted), and a+-- value which becomes the return value for the function as a whole.+-- The table sizing is enforced here, calling out to expandSubTable as+-- necessary.++-- This function is intended to be inlined and specialized for every+-- calling context (eg every provided bucketFn).+{-# INLINE updatingBucket #-}++updatingBucket :: Inserts -> ([(key,val)] -> ([(key,val)], Int32, a)) ->+                  HashTable key val -> key ->+                  IO a+updatingBucket canEnlarge bucketFn+               ht@HashTable{ tab=ref, hash_fn=hash } key = do+  (table@HT{ kcount=k, buckets=bkts, bmask=b },+   indx, bckt) <- findBucket ht key+  (bckt', inserts, result) <- return $ bucketFn bckt+  let k' = k + inserts+      table1 = table { kcount=k' }+  bkts' <- thawArray bkts+  writeMutArray bkts' indx bckt'+  freezeArray bkts'+  table2 <- if canEnlarge == CanInsert && inserts > 0 then do+               recordIns inserts k' bckt'+               if tooBig k' b+                  then expandHashTable hash table1+                  else return table1+            else return table1+  writeIORef ref table2+  return result++expandHashTable :: (key -> Int32) -> HT key val -> IO (HT key val)+expandHashTable hash table@HT{ buckets=bkts, bmask=mask } = do+   let+      oldsize = mask + 1+      newmask = mask + mask + 1+   recordResize oldsize (newmask+1)+   --+   if newmask > tABLE_MAX-1+      then return table+      else do+   --+    newbkts' <- newMutArray (0,newmask) []++    let+     splitBucket oldindex = do+       bucket <- readHTArray bkts oldindex+       let (oldb,newb) =+              partition ((oldindex==). bucketIndex newmask . hash . fst) bucket+       writeMutArray newbkts' oldindex oldb+       writeMutArray newbkts' (oldindex + oldsize) newb+    mapM_ splitBucket [0..mask]++    newbkts <- freezeArray newbkts'++    return ( table{ buckets=newbkts, bmask=newmask } )++-- -----------------------------------------------------------------------------+-- Deleting a mapping from the hash table++-- Remove a key from a bucket+deleteBucket :: (key -> Bool) -> [(key,val)] -> ([(key, val)], Int32, ())+deleteBucket _   [] = ([],0,())+deleteBucket del (pair@(k,_):bucket) =+  case deleteBucket del bucket of+    (bucket', dels, _) | del k     -> dels' `seq` (bucket', dels', ())+                       | otherwise -> (pair:bucket', dels, ())+      where dels' = dels - 1++-- | Remove an entry from the hash table.+delete :: HashTable key val -> key -> IO ()++delete ht@HashTable{ cmp=eq } key =+  updatingBucket Can'tInsert (deleteBucket (eq key)) ht key++-- -----------------------------------------------------------------------------+-- Updating a mapping in the hash table++-- | Updates an entry in the hash table, returning 'True' if there was+-- already an entry for this key, or 'False' otherwise.  After 'update'+-- there will always be exactly one entry for the given key in the table.+--+-- 'insert' is more efficient than 'update' if you don't care about+-- multiple entries, or you know for sure that multiple entries can't+-- occur.  However, 'update' is more efficient than 'delete' followed+-- by 'insert'.+update :: HashTable key val -> key -> val -> IO Bool++update ht@HashTable{ cmp=eq } key val =+  updatingBucket CanInsert+    (\bucket -> let (bucket', dels, _) = deleteBucket (eq key) bucket+                in  ((key,val):bucket', 1+dels, dels/=0))+    ht key++-- -----------------------------------------------------------------------------+-- Looking up an entry in the hash table++-- | Looks up the value of a key in the hash table.+lookup :: HashTable key val -> key -> IO (Maybe val)++lookup ht@HashTable{ cmp=eq } key = do+  recordLookup+  (_, _, bucket) <- findBucket ht key+  let firstHit (k,v) r | eq key k  = Just v+                       | otherwise = r+  return (foldr firstHit Nothing bucket)++-- -----------------------------------------------------------------------------+-- Converting to/from lists++-- | Convert a list of key\/value pairs into a hash table.  Equality on keys+-- is taken from the Eq instance for the key type.+--+fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val)+fromList hash list = do+  table <- new (==) hash+  sequence_ [ insert table k v | (k,v) <- list ]+  return table++-- | Converts a hash table to a list of key\/value pairs.+--+toList :: HashTable key val -> IO [(key,val)]+toList = mapReduce id concat++{-# INLINE mapReduce #-}+mapReduce :: ([(key,val)] -> r) -> ([r] -> r) -> HashTable key val -> IO r+mapReduce m r HashTable{ tab=ref } = do+  HT{ buckets=bckts, bmask=b } <- readIORef ref+  fmap r (mapM (fmap m . readHTArray bckts) [0..b])++-- -----------------------------------------------------------------------------+-- Diagnostics++-- | This function is useful for determining whether your hash+-- function is working well for your data set.  It returns the longest+-- chain of key\/value pairs in the hash table for which all the keys+-- hash to the same bucket.  If this chain is particularly long (say,+-- longer than 14 elements or so), then it might be a good idea to try+-- a different hash function.+--+longestChain :: HashTable key val -> IO [(key,val)]+longestChain = mapReduce id (maximumBy lengthCmp)+  where lengthCmp (_:x)(_:y) = lengthCmp x y+        lengthCmp []   []    = EQ+        lengthCmp []   _     = LT+        lengthCmp _    []    = GT
Data/IORef.hs view
@@ -1,2 +1,92 @@-module Data.IORef (module X___) where-import "base" Data.IORef as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,             -- :: a -> IO (IORef a)+        readIORef,            -- :: IORef a -> IO a+        writeIORef,           -- :: IORef a -> a -> IO ()+        modifyIORef,          -- :: IORef a -> (a -> a) -> IO ()+        atomicModifyIORef,    -- :: IORef a -> (a -> (a,b)) -> IO b++#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__)+        mkWeakIORef,          -- :: IORef a -> IO () -> IO (Weak (IORef a))+#endif+        ) where++#ifdef __HUGS__+import Hugs.IORef+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.STRef+import GHC.IOBase+#if !defined(__PARALLEL_HASKELL__)+import GHC.Weak+#endif+#endif /* __GLASGOW_HASKELL__ */++#ifdef __NHC__+import NHC.IOExtras+    ( IORef+    , newIORef+    , readIORef+    , writeIORef+    , excludeFinalisers+    )+#endif++#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__)+-- |Make a 'Weak' pointer to an 'IORef'+mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))+mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->+  case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)+#endif++-- |Mutate the contents of an 'IORef'+modifyIORef :: IORef a -> (a -> a) -> IO ()+modifyIORef ref f = readIORef ref >>= writeIORef ref . f+++-- |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 :: IORef a -> (a -> (a,b)) -> IO b+#if defined(__GLASGOW_HASKELL__)+atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s++#elif defined(__HUGS__)+atomicModifyIORef = plainModifyIORef    -- Hugs has no preemption+  where plainModifyIORef r f = do+                a <- readIORef r+                case f a of (a',b) -> writeIORef r a' >> return b+#elif defined(__NHC__)+atomicModifyIORef r f =+  excludeFinalisers $ do+    a <- readIORef r+    let (a',b) = f a+    writeIORef r a'+    return b+#endif
Data/Int.hs view
@@ -1,2 +1,65 @@-module Data.Int (module X___) where-import "base" Data.Int as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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++#ifdef __GLASGOW_HASKELL__+import GHC.Base ( Int )+import GHC.Int  ( Int8, Int16, Int32, Int64 )+#endif++#ifdef __HUGS__+import Hugs.Int ( Int8, Int16, Int32, Int64 )+#endif++#ifdef __NHC__+import Prelude+import Prelude (Int)+import NHC.FFI (Int8, Int16, Int32, Int64)+import NHC.SizedTypes (Int8, Int16, Int32, Int64)       -- instances of Bits+#endif++{- $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 view
@@ -1,2 +1,76 @@-module Data.Ix (module X___) where-import "base" Data.Ix as X___+-----------------------------------------------------------------------------+-- |+-- 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).+-- +-----------------------------------------------------------------------------+module Data.Ix+    (+    -- * The 'Ix' class+        Ix+          ( range       -- :: (Ix a) => (a,a) -> [a]+          , index       -- :: (Ix a) => (a,a) -> a   -> Int+          , inRange     -- :: (Ix a) => (a,a) -> a   -> Bool+          , rangeSize   -- :: (Ix a) => (a,a) -> Int+          )+    -- Ix instances:+    --+    --  Ix Char+    --  Ix Int+    --  Ix Integer+    --  Ix Bool+    --  Ix Ordering+    --  Ix ()+    --  (Ix a, Ix b) => Ix (a, b)+    --  ...++    -- Implementation checked wrt. Haskell 98 lib report, 1/99.++    -- * 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 Figure 1+    -- <http://www.haskell.org/onlinelibrary/ix.html#prelude-index>.++    ) where++import Prelude++#ifdef __GLASGOW_HASKELL__+import GHC.Arr+#endif++#ifdef __HUGS__+import Hugs.Prelude( Ix(..) )+#endif++#ifdef __NHC__+import Ix (Ix(..))+#endif+
Data/List.hs view
@@ -1,2 +1,1023 @@-module Data.List (module X___) where-import "base" Data.List as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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+   (+#ifdef __NHC__+     [] (..)+   ,+#endif++   -- * Basic functions++     (++)              -- :: [a] -> [a] -> [a]+   , head              -- :: [a] -> a+   , last              -- :: [a] -> a+   , tail              -- :: [a] -> [a]+   , init              -- :: [a] -> [a]+   , null              -- :: [a] -> Bool+   , length            -- :: [a] -> Int++   -- * List transformations+   , map               -- :: (a -> b) -> [a] -> [b]+   , reverse           -- :: [a] -> [a]++   , intersperse       -- :: a -> [a] -> [a]+   , intercalate       -- :: [a] -> [[a]] -> [a]+   , transpose         -- :: [[a]] -> [[a]]+   +   , subsequences      -- :: [a] -> [[a]]+   , permutations      -- :: [a] -> [[a]]++   -- * Reducing lists (folds)++   , foldl             -- :: (a -> b -> a) -> a -> [b] -> a+   , foldl'            -- :: (a -> b -> a) -> a -> [b] -> a+   , foldl1            -- :: (a -> a -> a) -> [a] -> a+   , foldl1'           -- :: (a -> a -> a) -> [a] -> a+   , foldr             -- :: (a -> b -> b) -> b -> [a] -> b+   , foldr1            -- :: (a -> a -> a) -> [a] -> a++   -- ** Special folds++   , concat            -- :: [[a]] -> [a]+   , concatMap         -- :: (a -> [b]) -> [a] -> [b]+   , and               -- :: [Bool] -> Bool+   , or                -- :: [Bool] -> Bool+   , any               -- :: (a -> Bool) -> [a] -> Bool+   , all               -- :: (a -> Bool) -> [a] -> Bool+   , sum               -- :: (Num a) => [a] -> a+   , product           -- :: (Num a) => [a] -> a+   , maximum           -- :: (Ord a) => [a] -> a+   , minimum           -- :: (Ord a) => [a] -> a++   -- * Building lists++   -- ** Scans+   , scanl             -- :: (a -> b -> a) -> a -> [b] -> [a]+   , scanl1            -- :: (a -> a -> a) -> [a] -> [a]+   , scanr             -- :: (a -> b -> b) -> b -> [a] -> [b]+   , scanr1            -- :: (a -> a -> a) -> [a] -> [a]++   -- ** Accumulating maps+   , mapAccumL         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])+   , mapAccumR         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])++   -- ** Infinite lists+   , iterate           -- :: (a -> a) -> a -> [a]+   , repeat            -- :: a -> [a]+   , replicate         -- :: Int -> a -> [a]+   , cycle             -- :: [a] -> [a]++   -- ** Unfolding+   , unfoldr           -- :: (b -> Maybe (a, b)) -> b -> [a]++   -- * Sublists++   -- ** Extracting sublists+   , take              -- :: Int -> [a] -> [a]+   , drop              -- :: Int -> [a] -> [a]+   , splitAt           -- :: Int -> [a] -> ([a], [a])++   , takeWhile         -- :: (a -> Bool) -> [a] -> [a]+   , dropWhile         -- :: (a -> Bool) -> [a] -> [a]+   , span              -- :: (a -> Bool) -> [a] -> ([a], [a])+   , break             -- :: (a -> Bool) -> [a] -> ([a], [a])++   , stripPrefix       -- :: Eq a => [a] -> [a] -> Maybe [a]++   , group             -- :: Eq a => [a] -> [[a]]++   , inits             -- :: [a] -> [[a]]+   , tails             -- :: [a] -> [[a]]++   -- ** Predicates+   , isPrefixOf        -- :: (Eq a) => [a] -> [a] -> Bool+   , isSuffixOf        -- :: (Eq a) => [a] -> [a] -> Bool+   , isInfixOf         -- :: (Eq a) => [a] -> [a] -> Bool++   -- * Searching lists++   -- ** Searching by equality+   , elem              -- :: a -> [a] -> Bool+   , notElem           -- :: a -> [a] -> Bool+   , lookup            -- :: (Eq a) => a -> [(a,b)] -> Maybe b++   -- ** Searching with a predicate+   , find              -- :: (a -> Bool) -> [a] -> Maybe a+   , filter            -- :: (a -> Bool) -> [a] -> [a]+   , partition         -- :: (a -> Bool) -> [a] -> ([a], [a])++   -- * Indexing lists+   -- | These functions treat a list @xs@ as a indexed collection,+   -- with indices ranging from 0 to @'length' xs - 1@.++   , (!!)              -- :: [a] -> Int -> a++   , elemIndex         -- :: (Eq a) => a -> [a] -> Maybe Int+   , elemIndices       -- :: (Eq a) => a -> [a] -> [Int]++   , findIndex         -- :: (a -> Bool) -> [a] -> Maybe Int+   , findIndices       -- :: (a -> Bool) -> [a] -> [Int]++   -- * Zipping and unzipping lists++   , zip               -- :: [a] -> [b] -> [(a,b)]+   , zip3+   , zip4, zip5, zip6, zip7++   , zipWith           -- :: (a -> b -> c) -> [a] -> [b] -> [c]+   , zipWith3+   , zipWith4, zipWith5, zipWith6, zipWith7++   , unzip             -- :: [(a,b)] -> ([a],[b])+   , unzip3+   , unzip4, unzip5, unzip6, unzip7++   -- * Special lists++   -- ** Functions on strings+   , lines             -- :: String   -> [String]+   , words             -- :: String   -> [String]+   , unlines           -- :: [String] -> String+   , unwords           -- :: [String] -> String++   -- ** \"Set\" operations++   , nub               -- :: (Eq a) => [a] -> [a]++   , delete            -- :: (Eq a) => a -> [a] -> [a]+   , (\\)              -- :: (Eq a) => [a] -> [a] -> [a]++   , union             -- :: (Eq a) => [a] -> [a] -> [a]+   , intersect         -- :: (Eq a) => [a] -> [a] -> [a]++   -- ** Ordered lists+   , sort              -- :: (Ord a) => [a] -> [a]+   , insert            -- :: (Ord a) => a -> [a] -> [a]++   -- * 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             -- :: (a -> a -> Bool) -> [a] -> [a]+   , deleteBy          -- :: (a -> a -> Bool) -> a -> [a] -> [a]+   , deleteFirstsBy    -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]+   , unionBy           -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]+   , intersectBy       -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]+   , groupBy           -- :: (a -> a -> Bool) -> [a] -> [[a]]++   -- *** User-supplied comparison (replacing an @Ord@ context)+   -- | The function is assumed to define a total ordering.+   , sortBy            -- :: (a -> a -> Ordering) -> [a] -> [a]+   , insertBy          -- :: (a -> a -> Ordering) -> a -> [a] -> [a]+   , maximumBy         -- :: (a -> a -> Ordering) -> [a] -> a+   , minimumBy         -- :: (a -> a -> Ordering) -> [a] -> a++   -- ** The \"@generic@\" operations+   -- | The prefix \`@generic@\' indicates an overloaded function that+   -- is a generalized version of a "Prelude" function.++   , genericLength     -- :: (Integral a) => [b] -> a+   , genericTake       -- :: (Integral a) => a -> [b] -> [b]+   , genericDrop       -- :: (Integral a) => a -> [b] -> [b]+   , genericSplitAt    -- :: (Integral a) => a -> [b] -> ([b], [b])+   , genericIndex      -- :: (Integral a) => [b] -> a -> b+   , genericReplicate  -- :: (Integral a) => a -> b -> [b]++   ) where++#ifdef __NHC__+import Prelude+#endif++import Data.Maybe+import Data.Char        ( isSpace )++#ifdef __GLASGOW_HASKELL__+import GHC.Num+import GHC.Real+import GHC.List+import GHC.Base+#endif++infix 5 \\ -- comment to fool cpp++-- -----------------------------------------------------------------------------+-- List functions++-- | 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       :: 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     :: 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            :: (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       :: (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      :: (a -> Bool) -> [a] -> [Int]++#if defined(USE_REPORT_PRELUDE) || !defined(__GLASGOW_HASKELL__)+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]+#else+-- Efficient definition+findIndices p ls = loop 0# ls+                 where+                   loop _ [] = []+                   loop n (x:xs) | p x       = I# n : loop (n +# 1#) xs+                                 | otherwise = loop (n +# 1#) xs+#endif  /* USE_REPORT_PRELUDE */++-- | The 'isPrefixOf' function takes two lists and returns 'True'+-- iff the first list is a prefix of the second.+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.+-- Both lists must be finite.+isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++-- | The 'isInfixOf' function takes two lists and returns 'True'+-- iff the first list is contained, wholly and intact,+-- anywhere within the second.+--+-- Example:+--+-- >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)++-- | 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                     :: (Eq a) => [a] -> [a]+#ifdef USE_REPORT_PRELUDE+nub                     =  nubBy (==)+#else+-- stolen from HBC+nub l                   = nub' l []             -- '+  where+    nub' [] _           = []                    -- '+    nub' (x:xs) ls                              -- '+        | x `elem` ls   = nub' xs ls            -- '+        | otherwise     = x : nub' xs (x:ls)    -- '+#endif++-- | The 'nubBy' function behaves just like 'nub', except it uses a+-- user-supplied equality predicate instead of the overloaded '=='+-- function.+nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+#ifdef USE_REPORT_PRELUDE+nubBy eq []             =  []+nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs)+#else+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 implementation+-- '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)     =  y `eq` x || elem_by eq y xs+#endif+++-- | '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 (==)++-- | The 'deleteBy' function behaves like 'delete', but takes a+-- user-supplied equality predicate.+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.+--+-- 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.+-- It is a special case of 'intersectBy', which allows the programmer to+-- supply their own equality test.++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 eq xs ys    =  [x | x <- xs, any (eq x) ys]++-- | 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 _   [x]     = [x]+intersperse sep (x:xs)  = x : sep : intersperse 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 :: [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]]++transpose               :: [[a]] -> [[a]]+transpose []             = []+transpose ([]   : xss)   = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss])+++-- | The 'partition' function takes a predicate 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               :: (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+mapAccumL _ s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++-- | 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++-- | The 'insert' function takes an element and a list and inserts the+-- element into the list at the last position where it is still 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 :: Ord a => a -> [a] -> [a]+insert e ls = insertBy (compare) e ls++-- | 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++#ifdef __GLASGOW_HASKELL__++-- | '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                 :: (Ord a) => [a] -> a+maximum []              =  errorEmptyList "maximum"+maximum xs              =  foldl1 max xs++{-# RULES+  "maximumInt"     maximum = (strictMaximum :: [Int]     -> Int);+  "maximumInteger" maximum = (strictMaximum :: [Integer] -> Integer)+ #-}++-- We can't make the overloaded version of maximum strict without+-- changing its semantics (max might not be strict), but we can for+-- the version specialised to 'Int'.+strictMaximum           :: (Ord a) => [a] -> a+strictMaximum []        =  errorEmptyList "maximum"+strictMaximum xs        =  foldl1' max xs++-- | 'minimum' returns the minimum value from a list,+-- which must be non-empty, finite, and of an ordered type.+-- It is a special case of 'Data.List.minimumBy', which allows the+-- programmer to supply their own comparison function.+minimum                 :: (Ord a) => [a] -> a+minimum []              =  errorEmptyList "minimum"+minimum xs              =  foldl1 min xs++{-# RULES+  "minimumInt"     minimum = (strictMinimum :: [Int]     -> Int);+  "minimumInteger" minimum = (strictMinimum :: [Integer] -> Integer)+ #-}++strictMinimum           :: (Ord a) => [a] -> a+strictMinimum []        =  errorEmptyList "minimum"+strictMinimum xs        =  foldl1' min xs++#endif /* __GLASGOW_HASKELL__ */++-- | 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.+maximumBy               :: (a -> a -> Ordering) -> [a] -> a+maximumBy _ []          =  error "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.+minimumBy               :: (a -> a -> Ordering) -> [a] -> a+minimumBy _ []          =  error "List.minimumBy: empty list"+minimumBy cmp xs        =  foldl1 minBy xs+                        where+                           minBy x y = case cmp x y of+                                       GT -> y+                                       _  -> x++-- | 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           :: (Num i) => [b] -> i+genericLength []        =  0+genericLength (_:l)     =  1 + genericLength l++-- | 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 -> [b] -> ([b],[b])+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 a) => [b] -> a -> b+genericIndex (x:_)  0 = x+genericIndex (_:xs) n+ | n > 0     = genericIndex xs (n-1)+ | otherwise = error "List.genericIndex: negative argument."+genericIndex _ _      = error "List.genericIndex: index too large."++-- | 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'.+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'.+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'.+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'.+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'.+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'.+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'.+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'.+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 _ _ _ _ _ _ _ _ = []++-- | The 'unzip4' function takes a list of quadruples and returns four+-- lists, analogous to 'unzip'.+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'.+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'.+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'.+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"]+--+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- | The 'tails' function returns all final segments of the argument,+-- longest first.  For example,+--+-- > tails "abc" == ["abc", "bc", "c",""]+--+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs+++-- | 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.+sort :: (Ord a) => [a] -> [a]++-- | The 'sortBy' function is the non-overloaded version of 'sort'.+sortBy :: (a -> a -> Ordering) -> [a] -> [a]++#ifdef USE_REPORT_PRELUDE+sort = sortBy compare+sortBy cmp = foldr (insertBy cmp) []+#else++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]++{-+OLD: 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 */++-- | 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]+--+unfoldr      :: (b -> Maybe (a, b)) -> b -> [a]+unfoldr f b  =+  case f b of+   Just (a,new_b) -> a : unfoldr f new_b+   Nothing        -> []++-- -----------------------------------------------------------------------------++-- | A strict version of 'foldl'.+foldl'           :: (a -> b -> a) -> a -> [b] -> a+#ifdef __GLASGOW_HASKELL__+foldl' f z0 xs0 = lgo z0 xs0+    where lgo z []     = z+          lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs+#else+foldl' f a []     = a+foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs+#endif++#ifdef __GLASGOW_HASKELL__+-- | 'foldl1' is a variant of 'foldl' that has no starting value argument,+-- and thus must be applied to non-empty lists.+foldl1                  :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)         =  foldl f x xs+foldl1 _ []             =  errorEmptyList "foldl1"+#endif /* __GLASGOW_HASKELL__ */++-- | A strict version of 'foldl1'+foldl1'                  :: (a -> a -> a) -> [a] -> a+foldl1' f (x:xs)         =  foldl' f x xs+foldl1' _ []             =  errorEmptyList "foldl1'"++#ifdef __GLASGOW_HASKELL__+-- -----------------------------------------------------------------------------+-- List sum and product++{-# SPECIALISE sum     :: [Int] -> Int #-}+{-# SPECIALISE sum     :: [Integer] -> Integer #-}+{-# SPECIALISE product :: [Int] -> Int #-}+{-# SPECIALISE product :: [Integer] -> Integer #-}+-- | The 'sum' function computes the sum of a finite list of numbers.+sum                     :: (Num a) => [a] -> a+-- | The 'product' function computes the product of a finite list of numbers.+product                 :: (Num a) => [a] -> a+#ifdef USE_REPORT_PRELUDE+sum                     =  foldl (+) 0+product                 =  foldl (*) 1+#else+sum     l       = sum' l 0+  where+    sum' []     a = a+    sum' (x:xs) a = sum' xs (a+x)+product l       = prod l 1+  where+    prod []     a = a+    prod (x:xs) a = prod xs (a*x)+#endif++-- -----------------------------------------------------------------------------+-- Functions on strings++-- | 'lines' breaks a string up into a list of strings at newline+-- characters.  The resulting strings do not contain newlines.+lines                   :: String -> [String]+lines ""                =  []+lines s                 =  let (l, s') = break (== '\n') s+                           in  l : case s' of+                                        []      -> []+                                        (_:s'') -> lines s''++-- | 'unlines' is an inverse operation to 'lines'.+-- It joins lines, after appending a terminating newline to each.+unlines                 :: [String] -> String+#ifdef 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                   :: String -> [String]+words s                 =  case dropWhile {-partain:Char.-}isSpace s of+                                "" -> []+                                s' -> w : words s''+                                      where (w, s'') =+                                             break {-partain:Char.-}isSpace s'++-- | 'unwords' is an inverse operation to 'words'.+-- It joins words with separating spaces.+unwords                 :: [String] -> String+#ifdef USE_REPORT_PRELUDE+unwords []              =  ""+unwords ws              =  foldr1 (\w s -> w ++ ' ':s) ws+#else+-- HBC version (stolen)+-- here's a more efficient version+unwords []              =  ""+unwords [w]             = w+unwords (w:ws)          = w ++ ' ' : unwords ws+#endif++#else  /* !__GLASGOW_HASKELL__ */++errorEmptyList :: String -> a+errorEmptyList fun =+  error ("Prelude." ++ fun ++ ": empty list")++#endif /* !__GLASGOW_HASKELL__ */
Data/Maybe.hs view
@@ -1,2 +1,148 @@-module Data.Maybe (module X___) where-import "base" Data.Maybe as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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)-- instance of: Eq, Ord, Show, Read,+                        --              Functor, Monad, MonadPlus++   , maybe              -- :: b -> (a -> b) -> Maybe a -> b++   , isJust             -- :: Maybe a -> Bool+   , isNothing          -- :: Maybe a -> Bool+   , fromJust           -- :: Maybe a -> a+   , fromMaybe          -- :: a -> Maybe a -> a+   , listToMaybe        -- :: [a] -> Maybe a+   , maybeToList        -- :: Maybe a -> [a]+   , catMaybes          -- :: [Maybe a] -> [a]+   , mapMaybe           -- :: (a -> Maybe b) -> [a] -> [b]+   ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#endif++#ifdef __NHC__+import Prelude+import Prelude (Maybe(..), maybe)+import Maybe+    ( isJust+    , isNothing+    , fromJust+    , fromMaybe+    , listToMaybe+    , maybeToList+    , catMaybes+    , mapMaybe+    )+#else++#ifndef __HUGS__+-- ---------------------------------------------------------------------------+-- The Maybe type, and instances++-- | The 'Maybe' type encapsulates an optional value.  A value of type+-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing').  Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic+-- measures such as 'error'.+--+-- The 'Maybe' type is also a monad.  It is a simple kind of error+-- monad, where all errors are represented by 'Nothing'.  A richer+-- error monad can be built using the 'Data.Either.Either' type.++data  Maybe a  =  Nothing | Just a+  deriving (Eq, Ord)++instance  Functor Maybe  where+    fmap _ Nothing       = Nothing+    fmap f (Just a)      = Just (f a)++instance  Monad Maybe  where+    (Just x) >>= k      = k x+    Nothing  >>= _      = Nothing++    (Just _) >>  k      = k+    Nothing  >>  _      = Nothing++    return              = Just+    fail _              = Nothing++-- ---------------------------------------------------------------------------+-- 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.+maybe :: b -> (a -> b) -> Maybe a -> b+maybe n _ Nothing  = n+maybe _ f (Just x) = f x+#endif  /* __HUGS__ */++-- | The 'isJust' function returns 'True' iff its argument is of the+-- form @Just _@.+isJust         :: Maybe a -> Bool+isJust Nothing = False+isJust _       = True++-- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'.+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'.+fromJust          :: Maybe a -> a+fromJust Nothing  = error "Maybe.fromJust: Nothing" -- yuck+fromJust (Just x) = x++-- | The 'fromMaybe' function takes a default value and and 'Maybe'+-- value.  If the 'Maybe' is 'Nothing', it returns the default values;+-- otherwise, it returns the value contained in the 'Maybe'.+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 not given 'Nothing'.+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.+listToMaybe           :: [a] -> Maybe a+listToMaybe []        =  Nothing+listToMaybe (a:_)     =  Just a++-- | The 'catMaybes' function takes a list of 'Maybe's and returns+-- a list of all the 'Just' values. +catMaybes              :: [Maybe a] -> [a]+catMaybes ls = [x | Just x <- ls]++-- | 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 just @'Just' b@, then @b@ is+-- included in the result list.+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++#endif /* else not __NHC__ */
Data/Monoid.hs view
@@ -1,2 +1,253 @@-module Data.Monoid (module X___) where-import "base" Data.Monoid as X___+-----------------------------------------------------------------------------+-- |+-- 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+--+-- The Monoid class with various general-purpose instances.+--+--    Inspired by the paper+--    /Functional Programming with Overloading and+--        Higher-Order Polymorphism/,+--      Mark P Jones (<http://citeseer.ist.psu.edu/jones95functional.html>)+--        Advanced School of Functional Programming, 1995.+-----------------------------------------------------------------------------++module Data.Monoid (+        -- * Monoid typeclass+        Monoid(..),+        Dual(..),+        Endo(..),+        -- * Bool wrappers+        All(..),+        Any(..),+        -- * Num wrappers+        Sum(..),+        Product(..),+        -- * Maybe wrappers+        -- $MaybeExamples+        First(..),+        Last(..)+  ) where++import Prelude++{-+-- just for testing+import Data.Maybe+import Test.QuickCheck+-- -}++-- ---------------------------------------------------------------------------+-- | The monoid class.+-- A minimal complete definition must supply 'mempty' and 'mappend',+-- and these should satisfy the monoid laws.++class Monoid a where+        mempty  :: a+        -- ^ Identity of 'mappend'+        mappend :: a -> a -> a+        -- ^ An associative operation+        mconcat :: [a] -> a++        -- ^ 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 = foldr mappend mempty++-- Monoid instances.++instance Monoid [a] where+        mempty  = []+        mappend = (++)++instance Monoid b => Monoid (a -> b) where+        mempty _ = mempty+        mappend f g x = f x `mappend` g x++instance Monoid () where+        -- Should it be strict?+        mempty        = ()+        _ `mappend` _ = ()+        mconcat _     = ()++instance (Monoid a, Monoid b) => Monoid (a,b) where+        mempty = (mempty, mempty)+        (a1,b1) `mappend` (a2,b2) =+                (a1 `mappend` a2, b1 `mappend` b2)++instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where+        mempty = (mempty, mempty, mempty)+        (a1,b1,c1) `mappend` (a2,b2,c2) =+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)++instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where+        mempty = (mempty, mempty, mempty, mempty)+        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =+                (a1 `mappend` a2, b1 `mappend` b2,+                 c1 `mappend` c2, d1 `mappend` d2)++instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>+                Monoid (a,b,c,d,e) where+        mempty = (mempty, mempty, mempty, mempty, mempty)+        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,+                 d1 `mappend` d2, e1 `mappend` e2)++-- lexicographical ordering+instance Monoid Ordering where+        mempty         = EQ+        LT `mappend` _ = LT+        EQ `mappend` y = y+        GT `mappend` _ = GT++-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.+newtype Dual a = Dual { getDual :: a }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Monoid a => Monoid (Dual a) where+        mempty = Dual mempty+        Dual x `mappend` Dual y = Dual (y `mappend` x)++-- | The monoid of endomorphisms under composition.+newtype Endo a = Endo { appEndo :: a -> a }++instance Monoid (Endo a) where+        mempty = Endo id+        Endo f `mappend` Endo g = Endo (f . g)++-- | Boolean monoid under conjunction.+newtype All = All { getAll :: Bool }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Monoid All where+        mempty = All True+        All x `mappend` All y = All (x && y)++-- | Boolean monoid under disjunction.+newtype Any = Any { getAny :: Bool }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Monoid Any where+        mempty = Any False+        Any x `mappend` Any y = Any (x || y)++-- | Monoid under addition.+newtype Sum a = Sum { getSum :: a }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Num a => Monoid (Sum a) where+        mempty = Sum 0+        Sum x `mappend` Sum y = Sum (x + y)++-- | Monoid under multiplication.+newtype Product a = Product { getProduct :: a }+        deriving (Eq, Ord, Read, Show, Bounded)++instance Num a => Monoid (Product a) where+        mempty = Product 1+        Product x `mappend` Product y = Product (x * y)++-- $MaybeExamples+-- To implement @find@ or @findLast@ on any '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's interface can be implemented with+-- Data.Map.alter. Some of the rest can be implemented with a new+-- @alterA@ function and either 'First' or 'Last':+--+-- > alterA :: (Applicative f, Ord k) =>+-- >           (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)+-- >+-- > instance Monoid a => Applicative ((,) a)  -- from Control.Applicative+--+-- @+-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v+--                     -> Map k v -> (Maybe v, Map k v)+-- insertLookupWithKey combine key value =+--   Arrow.first getFirst . alterA doChange key+--   where+--   doChange Nothing = (First Nothing, Just value)+--   doChange (Just oldValue) =+--     (First (Just oldValue),+--      Just (combine key value oldValue))+-- @++-- | 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+-- there is no \"Semigroup\" typeclass providing just 'mappend', we+-- use 'Monoid' instead.+instance Monoid a => Monoid (Maybe a) where+  mempty = Nothing+  Nothing `mappend` m = m+  m `mappend` Nothing = m+  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)+++-- | Maybe monoid returning the leftmost non-Nothing value.+newtype First a = First { getFirst :: Maybe a }+#ifndef __HADDOCK__+        deriving (Eq, Ord, Read, Show)+#else  /* __HADDOCK__ */+instance Eq a => Eq (First a)+instance Ord a => Ord (First a)+instance Read a => Read (First a)+instance Show a => Show (First a)+#endif++instance Monoid (First a) where+        mempty = First Nothing+        r@(First (Just _)) `mappend` _ = r+        First Nothing `mappend` r = r++-- | Maybe monoid returning the rightmost non-Nothing value.+newtype Last a = Last { getLast :: Maybe a }+#ifndef __HADDOCK__+        deriving (Eq, Ord, Read, Show)+#else  /* __HADDOCK__ */+instance Eq a => Eq (Last a)+instance Ord a => Ord (Last a)+instance Read a => Read (Last a)+instance Show a => Show (Last a)+#endif++instance Monoid (Last a) where+        mempty = Last Nothing+        _ `mappend` r@(Last (Just _)) = r+        r `mappend` Last Nothing = r++{-+{--------------------------------------------------------------------+  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)+-- -}
Data/Ord.hs view
@@ -1,2 +1,34 @@-module Data.Ord (module X___) where-import "base" Data.Ord as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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(..),+   comparing,+ ) where++#if __GLASGOW_HASKELL__+import GHC.Base+#endif++-- | +-- > 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)
Data/Ratio.hs view
@@ -1,2 +1,94 @@-module Data.Ratio (module X___) where-import "base" Data.Ratio as X___+-----------------------------------------------------------------------------+-- |+-- 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+    , (%)               -- :: (Integral a) => a -> a -> Ratio a+    , numerator         -- :: (Integral a) => Ratio a -> a+    , denominator       -- :: (Integral a) => Ratio a -> a+    , approxRational    -- :: (RealFrac a) => a -> a -> Rational++    -- Ratio instances: +    --   (Integral a) => Eq   (Ratio a)+    --   (Integral a) => Ord  (Ratio a)+    --   (Integral a) => Num  (Ratio a)+    --   (Integral a) => Real (Ratio a)+    --   (Integral a) => Fractional (Ratio a)+    --   (Integral a) => RealFrac (Ratio a)+    --   (Integral a) => Enum     (Ratio a)+    --   (Read a, Integral a) => Read (Ratio a)+    --   (Integral a) => Show     (Ratio a)++  ) where++import Prelude++#ifdef __GLASGOW_HASKELL__+import GHC.Real         -- The basic defns for Ratio+#endif++#ifdef __HUGS__+import Hugs.Prelude(Ratio(..), (%), numerator, denominator)+#endif++#ifdef __NHC__+import Ratio (Ratio(..), (%), numerator, denominator, approxRational)+#else++-- -----------------------------------------------------------------------------+-- 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  =  simplest (rat-eps) (rat+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''+#endif
Data/STRef.hs view
@@ -1,2 +1,41 @@-module Data.STRef (module X___) where-import "base" Data.STRef as X___+-----------------------------------------------------------------------------+-- |+-- 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, instance Eq+        newSTRef,       -- :: a -> ST s (STRef s a)+        readSTRef,      -- :: STRef s a -> ST s a+        writeSTRef,     -- :: STRef s a -> a -> ST s ()+        modifySTRef     -- :: STRef s a -> (a -> a) -> ST s ()+ ) where++import Prelude++#ifdef __GLASGOW_HASKELL__+import GHC.ST+import GHC.STRef+#endif++#ifdef __HUGS__+import Hugs.ST+import Data.Typeable++#include "Typeable.h"+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")+#endif++-- |Mutate the contents of an 'STRef'+modifySTRef :: STRef s a -> (a -> a) -> ST s ()+modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref
Data/STRef/Lazy.hs view
@@ -1,2 +1,34 @@-module Data.STRef.Lazy (module X___) where-import "base" Data.STRef.Lazy as X___+-----------------------------------------------------------------------------+-- |+-- 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, instance Eq+        newSTRef,       -- :: a -> ST s (STRef s a)+        readSTRef,      -- :: STRef s a -> ST s a+        writeSTRef,     -- :: STRef s a -> a -> ST s ()+        modifySTRef     -- :: STRef s a -> (a -> a) -> ST s ()+ ) 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 view
@@ -1,2 +1,20 @@-module Data.STRef.Strict (module X___) where-import "base" Data.STRef.Strict as X___+-----------------------------------------------------------------------------+-- |+-- 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 Prelude+import Data.STRef
Data/String.hs view
@@ -1,2 +1,31 @@-module Data.String (module X___) where-import "base" Data.String as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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+--+-- Things related to the String type.+--+-----------------------------------------------------------------------------++module Data.String (+   IsString(..)+ ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+#endif++-- | Class for string-like datastructures; used by the overloaded string+--   extension (-foverloaded-strings in GHC).+class IsString a where+    fromString :: String -> a++instance IsString [Char] where+    fromString xs = xs+
Data/Traversable.hs view
@@ -1,2 +1,190 @@-module Data.Traversable (module X___) where-import "base" Data.Traversable as X___+-----------------------------------------------------------------------------+-- |+-- 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.+--+-- See also+--+--  * /Applicative Programming with Effects/,+--    by Conor McBride and Ross Paterson, online at+--    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+--  * /The Essence of the Iterator Pattern/,+--    by Jeremy Gibbons and Bruno Oliveira,+--    in /Mathematically-Structured Functional Programming/, 2006, and online at+--    <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.+--+-- Note that the functions 'mapM' and 'sequence' generalize "Prelude"+-- functions of the same names from lists to any 'Traversable' functor.+-- To avoid ambiguity, either import the "Prelude" hiding these names+-- or qualify uses of these function names with an alias for this module.++module Data.Traversable (+        Traversable(..),+        for,+        forM,+        mapAccumL,+        mapAccumR,+        fmapDefault,+        foldMapDefault,+        ) where++import Prelude hiding (mapM, sequence, foldr)+import qualified Prelude (mapM, foldr)+import Control.Applicative+import Data.Foldable (Foldable())+import Data.Monoid (Monoid)++#if defined(__GLASGOW_HASKELL__)+import GHC.Arr+#elif defined(__HUGS__)+import Hugs.Array+#elif defined(__NHC__)+import Array+#endif++-- | Functors representing data structures that can be traversed from+-- left to right.+--+-- Minimal complete definition: 'traverse' or 'sequenceA'.+--+-- Instances are similar to 'Functor', e.g. given a data type+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be+--+-- > instance Traversable Tree+-- >    traverse f Empty = pure Empty+-- >    traverse f (Leaf x) = Leaf <$> f x+-- >    traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r+--+-- This is suitable even for abstract types, as the laws for '<*>'+-- imply a form of associativity.+--+-- 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').+--+class (Functor t, Foldable t) => Traversable t where+        -- | Map each element of a structure to an action, evaluate+        -- these actions from left to right, and collect the results.+        traverse :: Applicative f => (a -> f b) -> t a -> f (t b)+        traverse f = sequenceA . fmap f++        -- | Evaluate each action in the structure from left to right,+        -- and collect the results.+        sequenceA :: Applicative f => t (f a) -> f (t a)+        sequenceA = traverse id++        -- | Map each element of a structure to a monadic action, evaluate+        -- these actions from left to right, and collect the results.+        mapM :: Monad m => (a -> m b) -> t a -> m (t b)+        mapM f = unwrapMonad . traverse (WrapMonad . f)++        -- | Evaluate each monadic action in the structure from left to right,+        -- and collect the results.+        sequence :: Monad m => t (m a) -> m (t a)+        sequence = mapM id++-- instances for Prelude types++instance Traversable Maybe where+        traverse _ Nothing = pure Nothing+        traverse f (Just x) = Just <$> f x++instance Traversable [] where+        traverse f = Prelude.foldr cons_f (pure [])+          where cons_f x ys = (:) <$> f x <*> ys++        mapM = Prelude.mapM++instance Ix i => Traversable (Array i) where+        traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)++-- general functions++-- | 'for' is 'traverse' with its arguments flipped.+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.+forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)+{-# INLINE forM #-}+forM = flip mapM++-- left-to-right state transformer+newtype StateL s a = StateL { runStateL :: s -> (s, a) }++instance Functor (StateL s) where+        fmap f (StateL k) = StateL $ \ s ->+                let (s', v) = k s in (s', f v)++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)++-- |The 'mapAccumL' function behaves like a combination of 'fmap'+-- and '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.+mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s++-- right-to-left state transformer+newtype StateR s a = StateR { runStateR :: s -> (s, a) }++instance Functor (StateR s) where+        fmap f (StateR k) = StateR $ \ s ->+                let (s', v) = k s in (s', f v)++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)++-- |The 'mapAccumR' function behaves like a combination of 'fmap'+-- and '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.+mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s++-- | This function may be used as a value for `fmap` in a `Functor` instance.+fmapDefault :: Traversable t => (a -> b) -> t a -> t b+fmapDefault f = getId . traverse (Id . f)++-- | This function may be used as a value for `Data.Foldable.foldMap`+-- in a `Foldable` instance.+foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m+foldMapDefault f = getConst . traverse (Const . f)++-- local instances++newtype Id a = Id { getId :: a }++instance Functor Id where+        fmap f (Id x) = Id (f x)++instance Applicative Id where+        pure = Id+        Id f <*> Id x = Id (f x)
Data/Tuple.hs view
@@ -1,2 +1,182 @@-module Data.Tuple (module X___) where-import "base" Data.Tuple as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.+-----------------------------------------------------------------------------+-- |+-- 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+--+-- The tuple data types, and associated functions.+--+-----------------------------------------------------------------------------++module Data.Tuple+  ( fst         -- :: (a,b) -> a+  , snd         -- :: (a,b) -> a+  , curry       -- :: ((a, b) -> c) -> a -> b -> c+  , uncurry     -- :: (a -> b -> c) -> ((a, b) -> c)+#ifdef __NHC__+  , (,)(..)+  , (,,)(..)+  , (,,,)(..)+  , (,,,,)(..)+  , (,,,,,)(..)+  , (,,,,,,)(..)+  , (,,,,,,,)(..)+  , (,,,,,,,,)(..)+  , (,,,,,,,,,)(..)+  , (,,,,,,,,,,)(..)+  , (,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,,)(..)+#endif+  )+    where++#ifdef __GLASGOW_HASKELL__+import GHC.Bool+import GHC.Classes+import GHC.Ordering+-- XXX The standalone deriving clauses fail with+--     The data constructors of `(,)' are not all in scope+--       so you cannot derive an instance for it+--     In the stand-alone deriving instance for `Eq (a, b)'+-- if we don't import GHC.Tuple+import GHC.Tuple+#endif  /* __GLASGOW_HASKELL__ */++#ifdef __NHC__+import Prelude+import Prelude+  ( (,)(..)+  , (,,)(..)+  , (,,,)(..)+  , (,,,,)(..)+  , (,,,,,)(..)+  , (,,,,,,)(..)+  , (,,,,,,,)(..)+  , (,,,,,,,,)(..)+  , (,,,,,,,,,)(..)+  , (,,,,,,,,,,)(..)+  , (,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,)(..)+  , (,,,,,,,,,,,,,,)(..)+  -- nhc98's prelude only supplies tuple instances up to size 15+  , fst, snd+  , curry, uncurry+  )+#endif++default ()              -- Double isn't available yet++#ifdef __GLASGOW_HASKELL__+-- XXX Why aren't these derived?+instance Eq () where+    () == () = True+    () /= () = False++instance Ord () where+    () <= () = True+    () <  () = False+    () >= () = True+    () >  () = False+    max () () = ()+    min () () = ()+    compare () () = EQ++#ifndef __HADDOCK__+deriving instance (Eq  a, Eq  b) => Eq  (a, b)+deriving instance (Ord a, Ord b) => Ord (a, b)+deriving instance (Eq  a, Eq  b, Eq  c) => Eq  (a, b, c)+deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c)+deriving instance (Eq  a, Eq  b, Eq  c, Eq  d) => Eq  (a, b, c, d)+deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d)+deriving instance (Eq  a, Eq  b, Eq  c, Eq  d, Eq  e) => Eq  (a, b, c, d, e)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)+               => Eq (a, b, c, d, e, f)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f)+               => Ord (a, b, c, d, e, f)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g)+               => Eq (a, b, c, d, e, f, g)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g)+               => Ord (a, b, c, d, e, f, g)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h)+               => Eq (a, b, c, d, e, f, g, h)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h)+               => Ord (a, b, c, d, e, f, g, h)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i)+               => Eq (a, b, c, d, e, f, g, h, i)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i)+               => Ord (a, b, c, d, e, f, g, h, i)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j)+               => Eq (a, b, c, d, e, f, g, h, i, j)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j)+               => Ord (a, b, c, d, e, f, g, h, i, j)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k)+               => Eq (a, b, c, d, e, f, g, h, i, j, k)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k)+               => Ord (a, b, c, d, e, f, g, h, i, j, k)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,+                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o)+               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,+                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o)+               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+#endif  /* !__HADDOCK__ */+#endif  /* __GLASGOW_HASKELL__ */++-- ---------------------------------------------------------------------------+-- Standard functions over tuples++#if !defined(__HUGS__) && !defined(__NHC__)+-- | 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.+curry                   :: ((a, b) -> c) -> a -> b -> c+curry f x y             =  f (x, y)++-- | 'uncurry' converts a curried function to a function on pairs.+uncurry                 :: (a -> b -> c) -> ((a, b) -> c)+uncurry f p             =  f (fst p) (snd p)+#endif  /* neither __HUGS__ nor __NHC__ */
Data/Typeable.hs view
@@ -1,2 +1,647 @@-module Data.Typeable (module X___) where-import "base" Data.Typeable as X___+{-# OPTIONS_GHC -XNoImplicitPrelude -XOverlappingInstances -funbox-strict-fields #-}++-- The -XOverlappingInstances flag allows the user to over-ride+-- the instances for Typeable given here.  In particular, we provide an instance+--      instance ... => Typeable (s a) +-- But a user might want to say+--      instance ... => Typeable (MyType a b)++-----------------------------------------------------------------------------+-- |+-- 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.Generics" uses Typeable+-- and type-safe cast (but not dynamics) to support the \"Scrap your+-- boilerplate\" style of generic programming.+--+-----------------------------------------------------------------------------++module Data.Typeable+  (++        -- * The Typeable class+        Typeable( typeOf ),     -- :: a -> TypeRep++        -- * Type-safe cast+        cast,                   -- :: (Typeable a, Typeable b) => a -> Maybe b+        gcast,                  -- a generalisation of cast++        -- * Type representations+        TypeRep,        -- abstract, instance of: Eq, Show, Typeable+        TyCon,          -- abstract, instance of: Eq, Show, Typeable+        showsTypeRep,++        -- * Construction of type representations+        mkTyCon,        -- :: String  -> TyCon+        mkTyConApp,     -- :: TyCon   -> [TypeRep] -> TypeRep+        mkAppTy,        -- :: TypeRep -> TypeRep   -> TypeRep+        mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep++        -- * Observation of type representations+        splitTyConApp,  -- :: TypeRep -> (TyCon, [TypeRep])+        funResultTy,    -- :: TypeRep -> TypeRep   -> Maybe TypeRep+        typeRepTyCon,   -- :: TypeRep -> TyCon+        typeRepArgs,    -- :: TypeRep -> [TypeRep]+        tyConString,    -- :: TyCon   -> String+        typeRepKey,     -- :: TypeRep -> IO Int++        -- * The other Typeable classes+        -- | /Note:/ The general instances are provided for GHC only.+        Typeable1( typeOf1 ),   -- :: t a -> TypeRep+        Typeable2( typeOf2 ),   -- :: t a b -> TypeRep+        Typeable3( typeOf3 ),   -- :: t a b c -> TypeRep+        Typeable4( typeOf4 ),   -- :: t a b c d -> TypeRep+        Typeable5( typeOf5 ),   -- :: t a b c d e -> TypeRep+        Typeable6( typeOf6 ),   -- :: t a b c d e f -> TypeRep+        Typeable7( typeOf7 ),   -- :: t a b c d e f g -> TypeRep+        gcast1,                 -- :: ... => c (t a) -> Maybe (c (t' a))+        gcast2,                 -- :: ... => c (t a b) -> Maybe (c (t' a b))++        -- * Default instances+        -- | /Note:/ These are not needed by GHC, for which these instances+        -- are generated by general instance declarations.+        typeOfDefault,  -- :: (Typeable1 t, Typeable a) => t a -> TypeRep+        typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep+        typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep+        typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep+        typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep+        typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep+        typeOf6Default  -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep++  ) where++import qualified Data.HashTable as HT+import Data.Maybe+import Data.Int+import Data.Word+import Data.List( foldl, intersperse )+import Unsafe.Coerce++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Show         (Show(..), ShowS,+                         shows, showString, showChar, showParen)+import GHC.Err          (undefined)+import GHC.Num          (Integer, fromInteger, (+))+import GHC.Real         ( rem, Ratio )+import GHC.IOBase       (IORef,newIORef,unsafePerformIO)++-- These imports are so we can define Typeable instances+-- It'd be better to give Typeable instances in the modules themselves+-- but they all have to be compiled before Typeable+import GHC.IOBase       ( IOArray, IO, MVar, Handle, block )+import GHC.ST           ( ST )+import GHC.STRef        ( STRef )+import GHC.Ptr          ( Ptr, FunPtr )+import GHC.Stable       ( StablePtr, newStablePtr, freeStablePtr,+                          deRefStablePtr, castStablePtrToPtr,+                          castPtrToStablePtr )+import GHC.Arr          ( Array, STArray )++#endif++#ifdef __HUGS__+import Hugs.Prelude     ( Key(..), TypeRep(..), TyCon(..), Ratio,+                          Handle, Ptr, FunPtr, ForeignPtr, StablePtr )+import Hugs.IORef       ( IORef, newIORef, readIORef, writeIORef )+import Hugs.IOExts      ( unsafePerformIO )+        -- For the Typeable instance+import Hugs.Array       ( Array )+import Hugs.IOArray+import Hugs.ConcBase    ( MVar )+#endif++#ifdef __NHC__+import NHC.IOExtras (IOArray,IORef,newIORef,readIORef,writeIORef,unsafePerformIO)+import IO (Handle)+import Ratio (Ratio)+        -- For the Typeable instance+import NHC.FFI  ( Ptr,FunPtr,StablePtr,ForeignPtr )+import Array    ( Array )+#endif++#include "Typeable.h"++#ifndef __HUGS__++-------------------------------------------------------------+--+--              Type representations+--+-------------------------------------------------------------++-- | A concrete representation of a (monomorphic) type.  'TypeRep'+-- supports reasonably efficient equality.+data TypeRep = TypeRep !Key TyCon [TypeRep] ++-- Compare keys for equality+instance Eq TypeRep where+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2++-- | An abstract representation of a type constructor.  'TyCon' objects can+-- be built using 'mkTyCon'.+data TyCon = TyCon !Key String++instance Eq TyCon where+  (TyCon t1 _) == (TyCon t2 _) = t1 == t2+#endif++-- | Returns a unique integer associated with a 'TypeRep'.  This can+-- be used for making a mapping with TypeReps+-- as the keys, for example.  It is guaranteed that @t1 == t2@ if and only if+-- @typeRepKey t1 == typeRepKey t2@.+--+-- It is in the 'IO' monad because the actual value of the key may+-- vary from run to run of the program.  You should only rely on+-- the equality property, not any actual key value.  The relative ordering+-- of keys has no meaning either.+--+typeRepKey :: TypeRep -> IO Int+typeRepKey (TypeRep (Key i) _ _) = return i++        -- +        -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")+        --                                 [fTy,fTy,fTy])+        -- +        -- returns "(Foo,Foo,Foo)"+        --+        -- The TypeRep Show instance promises to print tuple types+        -- correctly. Tuple type constructors are specified by a +        -- sequence of commas, e.g., (mkTyCon ",,,,") returns+        -- the 5-tuple tycon.++----------------- Construction --------------------++-- | Applies a type constructor to a sequence of types+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep+mkTyConApp tc@(TyCon tc_k _) args +  = TypeRep (appKeys tc_k arg_ks) tc args+  where+    arg_ks = [k | TypeRep k _ _ <- args]++-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types.+mkFunTy  :: TypeRep -> TypeRep -> TypeRep+mkFunTy f a = mkTyConApp funTc [f,a]++-- | Splits a type constructor application+splitTyConApp :: TypeRep -> (TyCon,[TypeRep])+splitTyConApp (TypeRep _ tc trs) = (tc,trs)++-- | 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 trFun trArg+  = case splitTyConApp trFun of+      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2+      _ -> Nothing++-- | Adds a TypeRep argument to a TypeRep.+mkAppTy :: TypeRep -> TypeRep -> TypeRep+mkAppTy (TypeRep tr_k tc trs) arg_tr+  = let (TypeRep arg_k _ _) = arg_tr+     in  TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])++-- If we enforce the restriction that there is only one+-- @TyCon@ for a type & it is shared among all its uses,+-- we can map them onto Ints very simply. The benefit is,+-- of course, that @TyCon@s can then be compared efficiently.++-- Provided the implementor of other @Typeable@ instances+-- takes care of making all the @TyCon@s CAFs (toplevel constants),+-- this will work. ++-- If this constraint does turn out to be a sore thumb, changing+-- the Eq instance for TyCons is trivial.++-- | Builds a 'TyCon' object representing a type constructor.  An+-- implementation of "Data.Typeable" should ensure that the following holds:+--+-- >  mkTyCon "a" == mkTyCon "a"+--++mkTyCon :: String       -- ^ the name of the type constructor (should be unique+                        -- in the program, so it might be wise to use the+                        -- fully qualified name).+        -> TyCon        -- ^ A unique 'TyCon' object+mkTyCon str = TyCon (mkTyConKey str) str++----------------- Observation ---------------------++-- | Observe the type constructor of a type representation+typeRepTyCon :: TypeRep -> TyCon+typeRepTyCon (TypeRep _ tc _) = tc++-- | Observe the argument types of a type representation+typeRepArgs :: TypeRep -> [TypeRep]+typeRepArgs (TypeRep _ _ args) = args++-- | Observe string encoding of a type representation+tyConString :: TyCon   -> String+tyConString  (TyCon _ str) = str++----------------- Showing TypeReps --------------------++instance Show TypeRep where+  showsPrec p (TypeRep _ tycon tys) =+    case tys of+      [] -> showsPrec p tycon+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'+      [a,r] | tycon == funTc  -> showParen (p > 8) $+                                 showsPrec 9 a .+                                 showString " -> " .+                                 showsPrec 8 r+      xs | isTupleTyCon tycon -> showTuple xs+         | otherwise         ->+            showParen (p > 9) $+            showsPrec p tycon . +            showChar ' '      . +            showArgs tys++showsTypeRep :: TypeRep -> ShowS+showsTypeRep = shows++instance Show TyCon where+  showsPrec _ (TyCon _ s) = showString s++isTupleTyCon :: TyCon -> Bool+isTupleTyCon (TyCon _ ('(':',':_)) = True+isTupleTyCon _                     = False++-- Some (Show.TypeRep) helpers:++showArgs :: Show a => [a] -> ShowS+showArgs [] = id+showArgs [a] = showsPrec 10 a+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as ++showTuple :: [TypeRep] -> ShowS+showTuple args = showChar '('+               . (foldr (.) id $ intersperse (showChar ',') +                               $ map (showsPrec 10) args)+               . showChar ')'++-------------------------------------------------------------+--+--      The Typeable class and friends+--+-------------------------------------------------------------++-- | The class 'Typeable' allows a concrete representation of a type to+-- be calculated.+class Typeable a where+  typeOf :: a -> TypeRep+  -- ^ Takes a value of type @a@ and returns a concrete representation+  -- of that type.  The /value/ of the argument should be ignored by+  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as+  -- the argument.++-- | Variant for unary type constructors+class Typeable1 t where+  typeOf1 :: t a -> TypeRep++-- | For defining a 'Typeable' instance from any 'Typeable1' instance.+typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep+typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a -> a+   argType =  undefined++-- | Variant for binary type constructors+class Typeable2 t where+  typeOf2 :: t a b -> TypeRep++-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.+typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep+typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b -> a+   argType =  undefined++-- | Variant for 3-ary type constructors+class Typeable3 t where+  typeOf3 :: t a b c -> TypeRep++-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.+typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep+typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c -> a+   argType =  undefined++-- | Variant for 4-ary type constructors+class Typeable4 t where+  typeOf4 :: t a b c d -> TypeRep++-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.+typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep+typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d -> a+   argType =  undefined++-- | Variant for 5-ary type constructors+class Typeable5 t where+  typeOf5 :: t a b c d e -> TypeRep++-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.+typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep+typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d e -> a+   argType =  undefined++-- | Variant for 6-ary type constructors+class Typeable6 t where+  typeOf6 :: t a b c d e f -> TypeRep++-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.+typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep+typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d e f -> a+   argType =  undefined++-- | Variant for 7-ary type constructors+class Typeable7 t where+  typeOf7 :: t a b c d e f g -> TypeRep++-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.+typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep+typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)+ where+   argType :: t a b c d e f g -> a+   argType =  undefined++#ifdef __GLASGOW_HASKELL__+-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,+-- define the instances for partial applications.+-- Programmers using non-GHC implementations must do this manually+-- for each type constructor.+-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)++-- | One Typeable instance for all Typeable1 instances+instance (Typeable1 s, Typeable a)+       => Typeable (s a) where+  typeOf = typeOfDefault++-- | One Typeable1 instance for all Typeable2 instances+instance (Typeable2 s, Typeable a)+       => Typeable1 (s a) where+  typeOf1 = typeOf1Default++-- | One Typeable2 instance for all Typeable3 instances+instance (Typeable3 s, Typeable a)+       => Typeable2 (s a) where+  typeOf2 = typeOf2Default++-- | One Typeable3 instance for all Typeable4 instances+instance (Typeable4 s, Typeable a)+       => Typeable3 (s a) where+  typeOf3 = typeOf3Default++-- | One Typeable4 instance for all Typeable5 instances+instance (Typeable5 s, Typeable a)+       => Typeable4 (s a) where+  typeOf4 = typeOf4Default++-- | One Typeable5 instance for all Typeable6 instances+instance (Typeable6 s, Typeable a)+       => Typeable5 (s a) where+  typeOf5 = typeOf5Default++-- | One Typeable6 instance for all Typeable7 instances+instance (Typeable7 s, Typeable a)+       => Typeable6 (s a) where+  typeOf6 = typeOf6Default++#endif /* __GLASGOW_HASKELL__ */++-------------------------------------------------------------+--+--              Type-safe cast+--+-------------------------------------------------------------++-- | The type-safe cast operation+cast :: (Typeable a, Typeable b) => a -> Maybe b+cast x = r+       where+         r = if typeOf x == typeOf (fromJust r)+               then Just $ unsafeCoerce x+               else Nothing++-- | A flexible variation parameterised in a type constructor+gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)+gcast x = r+ where+  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))+        then Just $ unsafeCoerce x+        else Nothing+  getArg :: c x -> x +  getArg = undefined++-- | Cast for * -> *+gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a)) +gcast1 x = r+ where+  r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))+       then Just $ unsafeCoerce x+       else Nothing+  getArg :: c x -> x +  getArg = undefined++-- | Cast for * -> * -> *+gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b)) +gcast2 x = r+ where+  r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))+       then Just $ unsafeCoerce x+       else Nothing+  getArg :: c x -> x +  getArg = undefined++-------------------------------------------------------------+--+--      Instances of the Typeable classes for Prelude types+--+-------------------------------------------------------------++INSTANCE_TYPEABLE0((),unitTc,"()")+INSTANCE_TYPEABLE1([],listTc,"[]")+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")+INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")+INSTANCE_TYPEABLE2((->),funTc,"->")+INSTANCE_TYPEABLE1(IO,ioTc,"IO")++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+-- Types defined in GHC.IOBase+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )+#endif++INSTANCE_TYPEABLE2(Array,arrayTc,"Array")+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")++#ifdef __GLASGOW_HASKELL__+-- Hugs has these too, but their Typeable<n> instances are defined+-- elsewhere to keep this module within Haskell 98.+-- This is important because every invocation of runhugs or ffihugs+-- uses this module via Data.Dynamic.+INSTANCE_TYPEABLE2(ST,stTc,"ST")+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")+#endif++#ifndef __NHC__+INSTANCE_TYPEABLE2((,),pairTc,"(,)")+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")+INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")+#endif /* __NHC__ */++INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")+#ifndef __GLASGOW_HASKELL__+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")+#endif+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")++-------------------------------------------------------+--+-- Generate Typeable instances for standard datatypes+--+-------------------------------------------------------++INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")+INSTANCE_TYPEABLE0(Char,charTc,"Char")+INSTANCE_TYPEABLE0(Float,floatTc,"Float")+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")+INSTANCE_TYPEABLE0(Int,intTc,"Int")+#ifndef __NHC__+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )+#endif+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")++INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")++INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")++INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")++#ifdef __GLASGOW_HASKELL__+INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")+#endif++---------------------------------------------+--+--              Internals +--+---------------------------------------------++#ifndef __HUGS__+newtype Key = Key Int deriving( Eq )+#endif++data KeyPr = KeyPr !Key !Key deriving( Eq )++hashKP :: KeyPr -> Int32+hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime++data Cache = Cache { next_key :: !(IORef Key),  -- Not used by GHC (calls genSym instead)+                     tc_tbl   :: !(HT.HashTable String Key),+                     ap_tbl   :: !(HT.HashTable KeyPr Key) }++{-# NOINLINE cache #-}+#ifdef __GLASGOW_HASKELL__+foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore"+    getOrSetTypeableStore :: Ptr a -> IO (Ptr a)+#endif++cache :: Cache+cache = unsafePerformIO $ do+                empty_tc_tbl <- HT.new (==) HT.hashString+                empty_ap_tbl <- HT.new (==) hashKP+                key_loc      <- newIORef (Key 1) +                let ret = Cache {       next_key = key_loc,+                                        tc_tbl = empty_tc_tbl, +                                        ap_tbl = empty_ap_tbl }+#ifdef __GLASGOW_HASKELL__+                block $ do+                        stable_ref <- newStablePtr ret+                        let ref = castStablePtrToPtr stable_ref+                        ref2 <- getOrSetTypeableStore ref+                        if ref==ref2+                                then deRefStablePtr stable_ref+                                else do+                                        freeStablePtr stable_ref+                                        deRefStablePtr+                                                (castPtrToStablePtr ref2)+#else+                return ret+#endif++newKey :: IORef Key -> IO Key+#ifdef __GLASGOW_HASKELL__+newKey _ = do i <- genSym; return (Key i)+#else+newKey kloc = do { k@(Key i) <- readIORef kloc ;+                   writeIORef kloc (Key (i+1)) ;+                   return k }+#endif++#ifdef __GLASGOW_HASKELL__+foreign import ccall unsafe "genSymZh"+  genSym :: IO Int+#endif++mkTyConKey :: String -> Key+mkTyConKey str +  = unsafePerformIO $ do+        let Cache {next_key = kloc, tc_tbl = tbl} = cache+        mb_k <- HT.lookup tbl str+        case mb_k of+          Just k  -> return k+          Nothing -> do { k <- newKey kloc ;+                          HT.insert tbl str k ;+                          return k }++appKey :: Key -> Key -> Key+appKey k1 k2+  = unsafePerformIO $ do+        let Cache {next_key = kloc, ap_tbl = tbl} = cache+        mb_k <- HT.lookup tbl kpr+        case mb_k of+          Just k  -> return k+          Nothing -> do { k <- newKey kloc ;+                          HT.insert tbl kpr k ;+                          return k }+  where+    kpr = KeyPr k1 k2++appKeys :: Key -> [Key] -> Key+appKeys k ks = foldl appKey k ks
+ Data/Typeable.hs-boot view
@@ -0,0 +1,21 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module Data.Typeable where++import Data.Maybe+import GHC.Base+import GHC.Show++data TypeRep+data TyCon++mkTyCon      :: String -> TyCon+mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep+showsTypeRep :: TypeRep -> ShowS++cast :: (Typeable a, Typeable b) => a -> Maybe b++class Typeable a where+  typeOf :: a -> TypeRep+
Data/Unique.hs view
@@ -1,2 +1,59 @@-module Data.Unique (module X___) where-import "base" Data.Unique as X___+-----------------------------------------------------------------------------+-- |+-- 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,              -- instance (Eq, Ord)+   newUnique,           -- :: IO Unique+   hashUnique           -- :: Unique -> Int+ ) where++import Prelude++import Control.Concurrent.MVar+import System.IO.Unsafe (unsafePerformIO)++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Num+#endif++-- | An abstract unique object.  Objects of type 'Unique' may be+-- compared for equality and ordering and hashed into 'Int'.+newtype Unique = Unique Integer deriving (Eq,Ord)++uniqSource :: MVar Integer+uniqSource = unsafePerformIO (newMVar 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+   val <- takeMVar uniqSource+   let next = val+1+   putMVar uniqSource next+   return (Unique next)++-- | 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+#if defined(__GLASGOW_HASKELL__)+hashUnique (Unique i) = I# (hashInteger i)+#else+hashUnique (Unique u) = fromInteger (u `mod` (toInteger (maxBound :: Int) + 1))+#endif
Data/Version.hs view
@@ -1,2 +1,144 @@-module Data.Version (module X___) where-import "base" Data.Version as X___+-----------------------------------------------------------------------------+-- |+-- 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,+  ) where++import Prelude -- necessary to get dependencies right++-- These #ifdefs are necessary because this code might be compiled as+-- part of ghc/lib/compat, and hence might be compiled by an older version+-- of GHC.  In which case, we might need to pick up ReadP from +-- Distribution.Compat.ReadP, because the version in +-- Text.ParserCombinators.ReadP doesn't have all the combinators we need.+#if __GLASGOW_HASKELL__ || __HUGS__ || __NHC__+import Text.ParserCombinators.ReadP+#else+import Distribution.Compat.ReadP+#endif++#if !__GLASGOW_HASKELL__+import Data.Typeable    ( Typeable, TyCon, mkTyCon, mkTyConApp )+#else+import Data.Typeable    ( Typeable )+#endif++import Data.List        ( intersperse, sort )+import Control.Monad    ( liftM )+import Data.Char        ( isDigit, isAlphaNum )++{- |+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,Show+#if __GLASGOW_HASKELL__+        ,Typeable+#endif+        )++#if !__GLASGOW_HASKELL__+versionTc :: TyCon+versionTc = mkTyCon "Version"++instance Typeable Version where+  typeOf _ = mkTyConApp versionTc []+#endif++instance Eq Version where+  v1 == v2  =  versionBranch v1 == versionBranch v2 +                && sort (versionTags v1) == sort (versionTags v2)+                -- tags may be in any order++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'.+--+#if __GLASGOW_HASKELL__ || __HUGS__+parseVersion :: ReadP Version+#elif __NHC__+parseVersion :: ReadPN r Version+#else+parseVersion :: ReadP r Version+#endif+parseVersion = do branch <- sepBy1 (liftM read $ munch1 isDigit) (char '.')+                  tags   <- many (char '-' >> munch1 isAlphaNum)+                  return Version{versionBranch=branch, versionTags=tags}
Data/Word.hs view
@@ -1,2 +1,68 @@-module Data.Word (module X___) where-import "base" Data.Word as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,++        -- * Notes++        -- $notes+        ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Word+#endif++#ifdef __HUGS__+import Hugs.Word+#endif++#ifdef __NHC__+import NHC.FFI (Word8, Word16, Word32, Word64)+import NHC.SizedTypes (Word8, Word16, Word32, Word64)   -- instances of Bits+type Word = Word32+#endif++{- $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.++* It would be very natural to add a type @Natural@ providing an unbounded +  size unsigned integer, just as 'Prelude.Integer' provides unbounded+  size signed integers.  We do not do that yet since there is no demand+  for it.++* 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 view
@@ -1,2 +1,70 @@-module Debug.Trace (module X___) where-import "base" Debug.Trace as X___+-----------------------------------------------------------------------------+-- |+-- 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+--+-- The 'trace' function.+--+-----------------------------------------------------------------------------++module Debug.Trace (+        -- * Tracing+        putTraceMsg,      -- :: String -> IO ()+        trace,            -- :: String -> a -> a+        traceShow+  ) where++import Prelude+import System.IO.Unsafe++#ifdef __GLASGOW_HASKELL__+import Foreign.C.String+#else+import System.IO (hPutStrLn,stderr)+#endif++-- | 'putTraceMsg' function outputs the trace message from IO monad.+-- Usually the output stream is 'System.IO.stderr' but if the function is called+-- from Windows GUI application then the output will be directed to the Windows+-- debug console.+putTraceMsg :: String -> IO ()+putTraceMsg msg = do+#ifndef __GLASGOW_HASKELL__+    hPutStrLn stderr msg+#else+    withCString "%s\n" $ \cfmt ->+     withCString msg  $ \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 ()+#endif++{-# NOINLINE trace #-}+{-|+When called, 'trace' outputs the string in its first argument, before +returning the second argument as its result. The 'trace' function is not +referentially transparent, and should only be used for debugging, or for +monitoring execution. Some implementations of 'trace' may decorate the string +that\'s output to indicate that you\'re tracing. The function is implemented on+top of 'putTraceMsg'.+-}+trace :: String -> a -> a+trace string expr = unsafePerformIO $ do+    putTraceMsg string+    return expr++{-|+Like 'trace', but uses 'show' on the argument to convert it to a 'String'.++> traceShow = trace . show+-}+traceShow :: (Show a) => a -> b -> b+traceShow = trace . show
Foreign.hs view
@@ -1,2 +1,41 @@-module Foreign (module X___) where-import "base" Foreign as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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++        -- | For compatibility with the FFI addendum only.  The recommended+        -- place to get this from is "System.IO.Unsafe".+        , unsafePerformIO+        ) 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++import System.IO.Unsafe (unsafePerformIO)
Foreign/C.hs view
@@ -1,2 +1,24 @@-module Foreign.C (module X___) where-import "base" Foreign.C as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -1,2 +1,608 @@-module Foreign.C.Error (module X___) where-import "base" Foreign.C.Error as X___+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}+-----------------------------------------------------------------------------+-- |+-- 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(..),            -- instance: Eq++  -- ** 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, 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+                        -- :: Errno+  isValidErrno,         -- :: Errno -> Bool++  -- access to the current thread's "errno" value+  --+  getErrno,             -- :: IO Errno+  resetErrno,           -- :: IO ()++  -- conversion of an "errno" value into IO error+  --+  errnoToIOError,       -- :: String       -- location+                        -- -> Errno        -- errno+                        -- -> Maybe Handle -- handle+                        -- -> Maybe String -- filename+                        -- -> IOError++  -- throw current "errno" value+  --+  throwErrno,           -- ::                String               -> IO a++  -- ** Guards for IO operations that may fail++  throwErrnoIf,         -- :: (a -> Bool) -> String -> IO a       -> IO a+  throwErrnoIf_,        -- :: (a -> Bool) -> String -> IO a       -> IO ()+  throwErrnoIfRetry,    -- :: (a -> Bool) -> String -> IO a       -> IO a+  throwErrnoIfRetry_,   -- :: (a -> Bool) -> String -> IO a       -> IO ()+  throwErrnoIfMinus1,   -- :: Num a +                        -- =>                String -> IO a       -> IO a+  throwErrnoIfMinus1_,  -- :: Num a +                        -- =>                String -> IO a       -> IO ()+  throwErrnoIfMinus1Retry,+                        -- :: Num a +                        -- =>                String -> IO a       -> IO a+  throwErrnoIfMinus1Retry_,  +                        -- :: Num a +                        -- =>                String -> IO a       -> IO ()+  throwErrnoIfNull,     -- ::                String -> IO (Ptr a) -> IO (Ptr a)+  throwErrnoIfNullRetry,-- ::                String -> IO (Ptr a) -> IO (Ptr a)++  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+--+#ifndef __NHC__+#include "HsBaseConfig.h"+#endif++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Error    ( void )+import Data.Maybe++#if __GLASGOW_HASKELL__+import GHC.IOBase+import GHC.Num+import GHC.Base+#elif __HUGS__+import Hugs.Prelude             ( Handle, IOError, ioError )+import System.IO.Unsafe         ( unsafePerformIO )+#else+import System.IO                ( Handle )+import System.IO.Error          ( IOError, ioError )+import System.IO.Unsafe         ( unsafePerformIO )+import Foreign.Storable         ( Storable(poke,peek) )+#endif++#ifdef __HUGS__+{-# CFILES cbits/PrelIOUtils.c #-}+#endif+++-- "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++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, 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+#ifdef __NHC__+#include "Errno.hs"+#else+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)+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)+#endif++-- | 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.+--+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.+#ifdef __NHC__+getErrno = do e <- peek _errno; return (Errno e)+foreign import ccall unsafe "errno.h &errno" _errno :: Ptr CInt+#else+getErrno = do e <- get_errno; return (Errno e)+foreign import ccall unsafe "HsBase.h __hscore_get_errno" get_errno :: IO CInt+#endif++-- | Reset the current thread\'s @errno@ value to 'eOK'.+--+resetErrno :: IO ()++-- Again, setting errno has to be done via a C function.+#ifdef __NHC__+resetErrno = poke _errno 0+#else+resetErrno = set_errno 0+foreign import ccall unsafe "HsBase.h __hscore_set_errno" set_errno :: CInt -> IO ()+#endif++-- 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 checks for operations that would block and+-- executes an alternative action before retrying in that case.+--+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 :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1  = throwErrnoIf (== -1)++-- | as 'throwErrnoIfMinus1', but discards the result.+--+throwErrnoIfMinus1_ :: 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 :: Num a => String -> IO a -> IO a+throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)++-- | as 'throwErrnoIfMinus1', but discards the result.+--+throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()+throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)++-- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.+--+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a+throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)++-- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.+--+throwErrnoIfMinus1RetryMayBlock_ :: 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 :: Num a => String -> FilePath -> IO a -> IO a+throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)++-- | as 'throwErrnoIfMinus1_', but exceptions include the given path when+--   appropriate.+--+throwErrnoPathIfMinus1_ :: Num a => String -> FilePath -> IO a -> IO ()+throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)++-- conversion of an "errno" value into IO error+-- --------------------------------------------++-- | Construct a Haskell 98 I\/O error 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+#if __GLASGOW_HASKELL__+    return (IOError maybeHdl errType loc str maybeName)+    where+    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+#else+    return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))+#endif++foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
Foreign/C/String.hs view
@@ -1,2 +1,476 @@-module Foreign.C.String (module X___) where-import "base" Foreign.C.String as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,           -- = Ptr CChar+  CStringLen,        -- = (Ptr CChar, Int)++  -- ** Using a locale-dependent encoding++  -- | Currently these functions are identical to their @CAString@ counterparts;+  -- eventually they will use an encoding determined by the current locale.++  -- conversion of C strings into Haskell strings+  --+  peekCString,       -- :: CString    -> IO String+  peekCStringLen,    -- :: CStringLen -> IO String++  -- conversion of Haskell strings into C strings+  --+  newCString,        -- :: String -> IO CString+  newCStringLen,     -- :: String -> IO CStringLen++  -- conversion of Haskell strings into C strings using temporary storage+  --+  withCString,       -- :: String -> (CString    -> IO a) -> IO a+  withCStringLen,    -- :: String -> (CStringLen -> IO a) -> IO a++  charIsRepresentable, -- :: Char -> IO Bool++  -- ** 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,   -- :: Char -> CChar+  castCCharToChar,   -- :: CChar -> Char++  peekCAString,      -- :: CString    -> IO String+  peekCAStringLen,   -- :: CStringLen -> IO String+  newCAString,       -- :: String -> IO CString+  newCAStringLen,    -- :: String -> IO CStringLen+  withCAString,      -- :: String -> (CString    -> IO a) -> IO a+  withCAStringLen,   -- :: String -> (CStringLen -> IO a) -> IO a++  -- * 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,          -- = Ptr CWchar+  CWStringLen,       -- = (Ptr CWchar, Int)++  peekCWString,      -- :: CWString    -> IO String+  peekCWStringLen,   -- :: CWStringLen -> IO String+  newCWString,       -- :: String -> IO CWString+  newCWStringLen,    -- :: String -> IO CWStringLen+  withCWString,      -- :: String -> (CWString    -> IO a) -> IO a+  withCWStringLen,   -- :: String -> (CWStringLen -> IO a) -> IO a++  ) where++import Foreign.Marshal.Array+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable++import Data.Word++#ifdef __GLASGOW_HASKELL__+import GHC.List+import GHC.Real+import GHC.Num+import GHC.IOBase+import GHC.Base+#else+import Data.Char ( chr, ord )+#define unsafeChr chr+#endif++-----------------------------------------------------------------------------+-- 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 = peekCAString++-- | Marshal a C string with explicit length into a Haskell string.+--+peekCStringLen           :: CStringLen -> IO String+peekCStringLen = peekCAStringLen++-- | 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 = newCAString++-- | 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 = newCAStringLen++-- | 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 = withCAString++-- | 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 = withCAStringLen++-- | Determines whether a character can be accurately encoded in a 'CString'.+-- Unrepresentable characters are converted to @\'?\'@.+--+-- Currently only Latin-1 characters are representable.+charIsRepresentable :: Char -> IO Bool+charIsRepresentable c = return (ord c < 256)++-- 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)++-- | Marshal a NUL terminated C string into a Haskell string.+--+peekCAString    :: CString -> IO String+#ifndef __GLASGOW_HASKELL__+peekCAString cp  = do+  cs <- peekArray0 nUL cp+  return (cCharsToChars cs)+#else+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)+#endif++-- | Marshal a C string with explicit length into a Haskell string.+--+peekCAStringLen           :: CStringLen -> IO String+#ifndef __GLASGOW_HASKELL__+peekCAStringLen (cp, len)  = do+  cs <- peekArray len cp+  return (cCharsToChars cs)+#else+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)+#endif++-- | 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+#ifndef __GLASGOW_HASKELL__+newCAString  = newArray0 nUL . charsToCChars+#else+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+#endif++-- | 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+#ifndef __GLASGOW_HASKELL__+newCAStringLen str  = newArrayLen (charsToCChars str)+#else+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+#endif++-- | 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+#ifndef __GLASGOW_HASKELL__+withCAString  = withArray0 nUL . charsToCChars+#else+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+#endif++-- | 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    =+#ifndef __GLASGOW_HASKELL__+  withArrayLen (charsToCChars str) $ \ len ptr -> f (ptr, len)+#else+  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+#endif++-- 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)++#ifndef __GLASGOW_HASKELL__+-- cast [CChar] to [Char]+--+cCharsToChars :: [CChar] -> [Char]+cCharsToChars xs  = map castCCharToChar xs++-- cast [Char] to [CChar]+--+charsToCChars :: [Char] -> [CChar]+charsToCChars xs  = map castCharToCChar xs+#endif++-----------------------------------------------------------------------------+-- 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 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.+--+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]++#ifdef 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 view
@@ -1,2 +1,312 @@-module Foreign.C.Types (module X___) where-import "base" Foreign.C.Types as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+-- XXX -fno-warn-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+#ifndef __NHC__+          -- $ctypes++          -- ** Integral types+          -- | These types are are represented as @newtype@s of+          -- types in "Data.Int" and "Data.Word", and are instances of+          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',+          -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',+          -- 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' and+          -- 'Bits'.+          CChar,  CSChar,  CUChar+        , CShort, CUShort, CInt,   CUInt+        , CLong,  CULong+        , CPtrdiff, CSize, CWchar, CSigAtomic+        , CLLong, CULLong+        , CIntPtr, CUIntPtr+        , CIntMax, CUIntMax++          -- ** Numeric types+          -- | These types are 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', 'Typeable' and 'Storable'.+        , CClock,   CTime++          -- ** Floating types+          -- | These types are are represented as @newtype@s of+          -- 'Prelude.Float' and 'Prelude.Double', and are instances of+          -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',+          -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',+          -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',+          -- 'Prelude.RealFrac' and 'Prelude.RealFloat'.+        , CFloat,  CDouble, CLDouble+#else+          -- Exported non-abstractly in nhc98 to fix an interface file problem.+          CChar(..),    CSChar(..),  CUChar(..)+        , CShort(..),   CUShort(..), CInt(..),   CUInt(..)+        , CLong(..),    CULong(..)+        , CPtrdiff(..), CSize(..),   CWchar(..), CSigAtomic(..)+        , CLLong(..),   CULLong(..)+        , CClock(..),   CTime(..)+        , CFloat(..),   CDouble(..), CLDouble(..)+#endif+          -- ** Other types++          -- Instances of: Eq and Storable+        , CFile,        CFpos,     CJmpBuf+        ) where++#ifndef __NHC__++import {-# SOURCE #-} Foreign.Storable+import Data.Bits        ( Bits(..) )+import Data.Int         ( Int8,  Int16,  Int32,  Int64  )+import Data.Word        ( Word8, Word16, Word32, Word64 )+import {-# SOURCE #-} Data.Typeable++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Float+import GHC.Enum+import GHC.Real+import GHC.Show+import GHC.Read+import GHC.Num+#else+import Control.Monad    ( liftM )+#endif++#ifdef __HUGS__+import Hugs.Ptr         ( castPtr )+#endif++#include "HsBaseConfig.h"+#include "CTypes.h"++-- | Haskell type representing the C @char@ type.+INTEGRAL_TYPE(CChar,tyConCChar,"CChar",HTYPE_CHAR)+-- | Haskell type representing the C @signed char@ type.+INTEGRAL_TYPE(CSChar,tyConCSChar,"CSChar",HTYPE_SIGNED_CHAR)+-- | Haskell type representing the C @unsigned char@ type.+INTEGRAL_TYPE(CUChar,tyConCUChar,"CUChar",HTYPE_UNSIGNED_CHAR)++-- | Haskell type representing the C @short@ type.+INTEGRAL_TYPE(CShort,tyConCShort,"CShort",HTYPE_SHORT)+-- | Haskell type representing the C @unsigned short@ type.+INTEGRAL_TYPE(CUShort,tyConCUShort,"CUShort",HTYPE_UNSIGNED_SHORT)++-- | Haskell type representing the C @int@ type.+INTEGRAL_TYPE(CInt,tyConCInt,"CInt",HTYPE_INT)+-- | Haskell type representing the C @unsigned int@ type.+INTEGRAL_TYPE(CUInt,tyConCUInt,"CUInt",HTYPE_UNSIGNED_INT)++-- | Haskell type representing the C @long@ type.+INTEGRAL_TYPE(CLong,tyConCLong,"CLong",HTYPE_LONG)+-- | Haskell type representing the C @unsigned long@ type.+INTEGRAL_TYPE(CULong,tyConCULong,"CULong",HTYPE_UNSIGNED_LONG)++-- | Haskell type representing the C @long long@ type.+INTEGRAL_TYPE(CLLong,tyConCLLong,"CLLong",HTYPE_LONG_LONG)+-- | Haskell type representing the C @unsigned long long@ type.+INTEGRAL_TYPE(CULLong,tyConCULLong,"CULLong",HTYPE_UNSIGNED_LONG_LONG)++{-# RULES+"fromIntegral/a->CChar"   fromIntegral = \x -> CChar   (fromIntegral x)+"fromIntegral/a->CSChar"  fromIntegral = \x -> CSChar  (fromIntegral x)+"fromIntegral/a->CUChar"  fromIntegral = \x -> CUChar  (fromIntegral x)+"fromIntegral/a->CShort"  fromIntegral = \x -> CShort  (fromIntegral x)+"fromIntegral/a->CUShort" fromIntegral = \x -> CUShort (fromIntegral x)+"fromIntegral/a->CInt"    fromIntegral = \x -> CInt    (fromIntegral x)+"fromIntegral/a->CUInt"   fromIntegral = \x -> CUInt   (fromIntegral x)+"fromIntegral/a->CLong"   fromIntegral = \x -> CLong   (fromIntegral x)+"fromIntegral/a->CULong"  fromIntegral = \x -> CULong  (fromIntegral x)+"fromIntegral/a->CLLong"  fromIntegral = \x -> CLLong  (fromIntegral x)+"fromIntegral/a->CULLong" fromIntegral = \x -> CULLong (fromIntegral x)++"fromIntegral/CChar->a"   fromIntegral = \(CChar   x) -> fromIntegral x+"fromIntegral/CSChar->a"  fromIntegral = \(CSChar  x) -> fromIntegral x+"fromIntegral/CUChar->a"  fromIntegral = \(CUChar  x) -> fromIntegral x+"fromIntegral/CShort->a"  fromIntegral = \(CShort  x) -> fromIntegral x+"fromIntegral/CUShort->a" fromIntegral = \(CUShort x) -> fromIntegral x+"fromIntegral/CInt->a"    fromIntegral = \(CInt    x) -> fromIntegral x+"fromIntegral/CUInt->a"   fromIntegral = \(CUInt   x) -> fromIntegral x+"fromIntegral/CLong->a"   fromIntegral = \(CLong   x) -> fromIntegral x+"fromIntegral/CULong->a"  fromIntegral = \(CULong  x) -> fromIntegral x+"fromIntegral/CLLong->a"  fromIntegral = \(CLLong  x) -> fromIntegral x+"fromIntegral/CULLong->a" fromIntegral = \(CULLong x) -> fromIntegral x+ #-}++-- | Haskell type representing the C @float@ type.+FLOATING_TYPE(CFloat,tyConCFloat,"CFloat",HTYPE_FLOAT)+-- | Haskell type representing the C @double@ type.+FLOATING_TYPE(CDouble,tyConCDouble,"CDouble",HTYPE_DOUBLE)+-- HACK: Currently no long double in the FFI, so we simply re-use double+-- | Haskell type representing the C @long double@ type.+FLOATING_TYPE(CLDouble,tyConCLDouble,"CLDouble",HTYPE_DOUBLE)++{-# RULES+"realToFrac/a->CFloat"    realToFrac = \x -> CFloat   (realToFrac x)+"realToFrac/a->CDouble"   realToFrac = \x -> CDouble  (realToFrac x)+"realToFrac/a->CLDouble"  realToFrac = \x -> CLDouble (realToFrac x)++"realToFrac/CFloat->a"    realToFrac = \(CFloat   x) -> realToFrac x+"realToFrac/CDouble->a"   realToFrac = \(CDouble  x) -> realToFrac x+"realToFrac/CLDouble->a"  realToFrac = \(CLDouble x) -> realToFrac x+ #-}++-- | Haskell type representing the C @ptrdiff_t@ type.+INTEGRAL_TYPE(CPtrdiff,tyConCPtrdiff,"CPtrdiff",HTYPE_PTRDIFF_T)+-- | Haskell type representing the C @size_t@ type.+INTEGRAL_TYPE(CSize,tyConCSize,"CSize",HTYPE_SIZE_T)+-- | Haskell type representing the C @wchar_t@ type.+INTEGRAL_TYPE(CWchar,tyConCWchar,"CWchar",HTYPE_WCHAR_T)+-- | Haskell type representing the C @sig_atomic_t@ type.+INTEGRAL_TYPE(CSigAtomic,tyConCSigAtomic,"CSigAtomic",HTYPE_SIG_ATOMIC_T)++{-# RULES+"fromIntegral/a->CPtrdiff"   fromIntegral = \x -> CPtrdiff   (fromIntegral x)+"fromIntegral/a->CSize"      fromIntegral = \x -> CSize      (fromIntegral x)+"fromIntegral/a->CWchar"     fromIntegral = \x -> CWchar     (fromIntegral x)+"fromIntegral/a->CSigAtomic" fromIntegral = \x -> CSigAtomic (fromIntegral x)++"fromIntegral/CPtrdiff->a"   fromIntegral = \(CPtrdiff   x) -> fromIntegral x+"fromIntegral/CSize->a"      fromIntegral = \(CSize      x) -> fromIntegral x+"fromIntegral/CWchar->a"     fromIntegral = \(CWchar     x) -> fromIntegral x+"fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x+ #-}++-- | Haskell type representing the C @clock_t@ type.+ARITHMETIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T)+-- | Haskell type representing the C @time_t@ type.+--+-- To convert to a @Data.Time.UTCTime@, use the following formula:+--+-- >  posixSecondsToUTCTime (realToFrac :: POSIXTime)+--+ARITHMETIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T)++-- FIXME: Implement and provide instances for Eq and Storable+-- | Haskell type representing the C @FILE@ type.+data CFile = CFile+-- | Haskell type representing the C @fpos_t@ type.+data CFpos = CFpos+-- | Haskell type representing the C @jmp_buf@ type.+data CJmpBuf = CJmpBuf++INTEGRAL_TYPE(CIntPtr,tyConCIntPtr,"CIntPtr",HTYPE_INTPTR_T)+INTEGRAL_TYPE(CUIntPtr,tyConCUIntPtr,"CUIntPtr",HTYPE_UINTPTR_T)+INTEGRAL_TYPE(CIntMax,tyConCIntMax,"CIntMax",HTYPE_INTMAX_T)+INTEGRAL_TYPE(CUIntMax,tyConCUIntMax,"CUIntMax",HTYPE_UINTMAX_T)++{-# RULES+"fromIntegral/a->CIntPtr"  fromIntegral = \x -> CIntPtr  (fromIntegral x)+"fromIntegral/a->CUIntPtr" fromIntegral = \x -> CUIntPtr (fromIntegral x)+"fromIntegral/a->CIntMax"  fromIntegral = \x -> CIntMax  (fromIntegral x)+"fromIntegral/a->CUIntMax" fromIntegral = \x -> CUIntMax (fromIntegral x)+ #-}++-- 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@.++-}++#else   /* __NHC__ */++import NHC.FFI+  ( CChar(..),    CSChar(..),  CUChar(..)+  , CShort(..),   CUShort(..), CInt(..),   CUInt(..)+  , CLong(..),    CULong(..),  CLLong(..), CULLong(..)+  , CPtrdiff(..), CSize(..),   CWchar(..), CSigAtomic(..)+  , CClock(..),   CTime(..)+  , CFloat(..),   CDouble(..), CLDouble(..)+  , CFile,        CFpos,       CJmpBuf+  , Storable(..)+  )+import Data.Bits+import NHC.SizedTypes++#define INSTANCE_BITS(T) \+instance Bits T where { \+  (T x) .&.     (T y)   = T (x .&.   y) ; \+  (T x) .|.     (T y)   = T (x .|.   y) ; \+  (T x) `xor`   (T y)   = T (x `xor` y) ; \+  complement    (T x)   = T (complement x) ; \+  shift         (T x) n = T (shift x n) ; \+  rotate        (T x) n = T (rotate x n) ; \+  bit                 n = T (bit n) ; \+  setBit        (T x) n = T (setBit x n) ; \+  clearBit      (T x) n = T (clearBit x n) ; \+  complementBit (T x) n = T (complementBit x n) ; \+  testBit       (T x) n = testBit x n ; \+  bitSize       (T x)   = bitSize x ; \+  isSigned      (T x)   = isSigned x }++INSTANCE_BITS(CChar)+INSTANCE_BITS(CSChar)+INSTANCE_BITS(CUChar)+INSTANCE_BITS(CShort)+INSTANCE_BITS(CUShort)+INSTANCE_BITS(CInt)+INSTANCE_BITS(CUInt)+INSTANCE_BITS(CLong)+INSTANCE_BITS(CULong)+INSTANCE_BITS(CLLong)+INSTANCE_BITS(CULLong)+INSTANCE_BITS(CPtrdiff)+INSTANCE_BITS(CWchar)+INSTANCE_BITS(CSigAtomic)+INSTANCE_BITS(CSize)++#endif
Foreign/Concurrent.hs view
@@ -1,2 +1,54 @@-module Foreign.Concurrent (module X___) where-import "base" Foreign.Concurrent as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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++#ifdef __GLASGOW_HASKELL__+import GHC.IOBase       ( IO )+import GHC.Ptr          ( Ptr )+import GHC.ForeignPtr   ( ForeignPtr )+import qualified GHC.ForeignPtr+#endif++#ifdef __GLASGOW_HASKELL__+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 finalizer will be executed after the last reference to the+-- foreign object is dropped.  Note that there is no guarantee on how+-- soon the finalizer is executed after the last reference was dropped;+-- this depends on the details of the Haskell storage manager.  The only+-- guarantee is that the finalizer runs before the program terminates.+newForeignPtr = GHC.ForeignPtr.newConcForeignPtr++addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO ()+-- ^This function adds a finalizer to the given 'ForeignPtr'.+-- The finalizer will run after the last reference to the foreign object+-- is dropped, but /before/ all previously registered finalizers for the+-- same object.+addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer+#endif
Foreign/ForeignPtr.hs view
@@ -1,2 +1,200 @@-module Foreign.ForeignPtr (module X___) where-import "base" Foreign.ForeignPtr as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++module Foreign.ForeignPtr+        ( +        -- * Finalised data pointers+          ForeignPtr+        , FinalizerPtr+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+        , FinalizerEnvPtr+#endif+        -- ** Basic operations+        , newForeignPtr+        , newForeignPtr_+        , addForeignPtrFinalizer+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+        , newForeignPtrEnv+        , addForeignPtrFinalizerEnv+#endif+        , withForeignPtr++#ifdef __GLASGOW_HASKELL__+        , finalizeForeignPtr+#endif++        -- ** Low-level operations+        , unsafeForeignPtrToPtr+        , touchForeignPtr+        , castForeignPtr++        -- ** Allocating managed memory+        , mallocForeignPtr+        , mallocForeignPtrBytes+        , mallocForeignPtrArray+        , mallocForeignPtrArray0+        ) +        where++import Foreign.Ptr++#ifdef __NHC__+import NHC.FFI+  ( ForeignPtr+  , FinalizerPtr+  , newForeignPtr+  , newForeignPtr_+  , addForeignPtrFinalizer+  , withForeignPtr+  , unsafeForeignPtrToPtr+  , touchForeignPtr+  , castForeignPtr+  , Storable(sizeOf)+  , malloc, mallocBytes, finalizerFree+  )+#endif++#ifdef __HUGS__+import Hugs.ForeignPtr+#endif++#ifndef __NHC__+import Foreign.Storable ( Storable(sizeOf) )+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import GHC.Num+import GHC.Err          ( undefined )+import GHC.ForeignPtr+#endif++#if !defined(__NHC__) && !defined(__GLASGOW_HASKELL__)+import Foreign.Marshal.Alloc    ( malloc, mallocBytes, finalizerFree )++instance Eq (ForeignPtr a) where +    p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q++instance Ord (ForeignPtr a) where +    compare p q  =  compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)++instance Show (ForeignPtr a) where+    showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)+#endif+++#ifndef __NHC__+newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)+-- ^Turns a plain memory reference into a foreign pointer, and+-- associates a finaliser with the reference.  The finaliser will be executed+-- after the last reference to the foreign object is dropped.  Note that there+-- is no guarantee on how soon the finaliser is executed after the last+-- reference was dropped; this depends on the details of the Haskell storage+-- manager.  Indeed, there is no guarantee that the finalizer is executed at+-- all; a program may exit with finalizers outstanding.  (This is true+-- of GHC, other implementations may give stronger guarantees).+newForeignPtr finalizer p+  = do fObj <- newForeignPtr_ p+       addForeignPtrFinalizer finalizer fObj+       return fObj++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 io+  = do r <- io (unsafeForeignPtrToPtr fo)+       touchForeignPtr fo+       return r+#endif /* ! __NHC__ */++#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)+-- | 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+#endif /* __HUGS__ */++#ifdef __GLASGOW_HASKELL__+type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())++-- | like 'addForeignPtrFinalizerEnv' but allows the finalizer to be+-- passed an additional environment parameter to be passed to the+-- finalizer.  The environment passed to the finalizer is fixed by the+-- second argument to 'addForeignPtrFinalizerEnv'+addForeignPtrFinalizerEnv ::+  FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()+addForeignPtrFinalizerEnv finalizer env fptr = +  addForeignPtrConcFinalizer fptr +        (mkFinalizerEnv finalizer env (unsafeForeignPtrToPtr fptr))++foreign import ccall "dynamic" +  mkFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO ()+#endif+++#ifndef __GLASGOW_HASKELL__+mallocForeignPtr :: Storable a => IO (ForeignPtr a)+mallocForeignPtr = do+  r <- malloc+  newForeignPtr finalizerFree r++mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytes n = do+  r <- mallocBytes n+  newForeignPtr finalizerFree r+#endif /* !__GLASGOW_HASKELL__ */++-- | 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/Marshal.hs view
@@ -1,2 +1,28 @@-module Foreign.Marshal (module X___) where-import "base" Foreign.Marshal as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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+        ( 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 view
@@ -1,2 +1,198 @@-module Foreign.Marshal.Alloc (module X___) where-import "base" Foreign.Marshal.Alloc as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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+--+-- Marshalling support: basic routines for memory allocation+--+-----------------------------------------------------------------------------++module Foreign.Marshal.Alloc (+  -- * Memory allocation+  -- ** Local allocation+  alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b+  allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b++  -- ** Dynamic allocation+  malloc,       -- :: Storable a =>        IO (Ptr a)+  mallocBytes,  -- ::               Int -> IO (Ptr a)++  realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)+  reallocBytes, -- ::               Ptr a -> Int -> IO (Ptr a)++  free,         -- :: Ptr a -> IO ()+  finalizerFree -- :: FinalizerPtr a+) where++import Data.Maybe+import Foreign.C.Types          ( CSize )+import Foreign.Storable         ( Storable(sizeOf) )++#ifndef __GLASGOW_HASKELL__+import Foreign.Ptr              ( Ptr, nullPtr, FunPtr )+#endif++#ifdef __GLASGOW_HASKELL__+import Foreign.ForeignPtr       ( FinalizerPtr )+import GHC.IOBase+import GHC.Real+import GHC.Ptr+import GHC.Err+import GHC.Base+import GHC.Num+#elif defined(__NHC__)+import NHC.FFI                  ( FinalizerPtr, CInt(..) )+import IO                       ( bracket )+#else+import Control.Exception.Base   ( bracket )+#endif++#ifdef __HUGS__+import Hugs.Prelude             ( IOException(IOError),+                                  IOErrorType(ResourceExhausted) )+import Hugs.ForeignPtr          ( FinalizerPtr )+#endif+++-- 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.+--+malloc :: Storable a => IO (Ptr a)+malloc  = doMalloc undefined+  where+    doMalloc       :: Storable b => b -> IO (Ptr b)+    doMalloc dummy  = mallocBytes (sizeOf dummy)++-- |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))++-- |@'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.+--+alloca :: Storable a => (Ptr a -> IO b) -> IO b+alloca  = doAlloca undefined+  where+    doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy  = allocaBytes (sizeOf dummy)++-- |@'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.+--+#ifdef __GLASGOW_HASKELL__+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' ->+     case action' s2      of { (# s3, r #) ->+     case touch# barr# s3 of { s4 ->+     (# s4, r #)+  }}}}}+#else+allocaBytes      :: Int -> (Ptr a -> IO b) -> IO b+allocaBytes size  = bracket (mallocBytes size) free+#endif++-- |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 :: Storable b => Ptr a -> IO (Ptr b)+realloc  = doRealloc undefined+  where+    doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')+    doRealloc dummy ptr  = let+                             size = fromIntegral (sizeOf dummy)+                           in+                           failWhenNULL "realloc" (_realloc ptr size)++-- |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+++-- auxilliary 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+#if __GLASGOW_HASKELL__ || __HUGS__+      then ioError (IOError Nothing ResourceExhausted name +                                        "out of memory" Nothing)+#else+      then ioError (userError (name++": out of memory"))+#endif+      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 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 view
@@ -1,2 +1,276 @@-module Foreign.Marshal.Array (module X___) where-import "base" Foreign.Marshal.Array as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,    -- :: Storable a => Int -> IO (Ptr a)+  mallocArray0,   -- :: Storable a => Int -> IO (Ptr a)++  allocaArray,    -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b+  allocaArray0,   -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b++  reallocArray,   -- :: Storable a => Ptr a -> Int -> IO (Ptr a)+  reallocArray0,  -- :: Storable a => Ptr a -> Int -> IO (Ptr a)++  -- ** Marshalling+  --+  peekArray,      -- :: Storable a =>         Int -> Ptr a -> IO [a]+  peekArray0,     -- :: (Storable a, Eq a) => a   -> Ptr a -> IO [a]++  pokeArray,      -- :: Storable a =>      Ptr a -> [a] -> IO ()+  pokeArray0,     -- :: Storable a => a -> Ptr a -> [a] -> IO ()++  -- ** Combined allocation and marshalling+  --+  newArray,       -- :: Storable a =>      [a] -> IO (Ptr a)+  newArray0,      -- :: Storable a => a -> [a] -> IO (Ptr a)++  withArray,      -- :: Storable a =>      [a] -> (Ptr a -> IO b) -> IO b+  withArray0,     -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b++  withArrayLen,   -- :: Storable a =>      [a] -> (Int -> Ptr a -> IO b) -> IO b+  withArrayLen0,  -- :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b++  -- ** Copying++  -- | (argument order: destination, source)+  copyArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+  moveArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()++  -- ** Finding the length+  --+  lengthArray0,   -- :: (Storable a, Eq a) => a -> Ptr a -> IO Int++  -- ** Indexing+  --+  advancePtr,     -- :: Storable a => Ptr a -> Int -> Ptr a+) where++import Foreign.Ptr      (Ptr, plusPtr)+import Foreign.Storable (Storable(sizeOf,peekElemOff,pokeElemOff))+import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)+import Foreign.Marshal.Utils (copyBytes, moveBytes)++#ifdef __GLASGOW_HASKELL__+import GHC.IOBase+import GHC.Num+import GHC.List+import GHC.Err+import GHC.Base+#else+import Control.Monad (zipWithM_)+#endif++-- allocation+-- ----------++-- |Allocate storage for the given number of elements of a storable type+-- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).+--+mallocArray :: Storable a => Int -> IO (Ptr a)+mallocArray  = doMalloc undefined+  where+    doMalloc            :: Storable a' => a' -> Int -> IO (Ptr a')+    doMalloc dummy size  = mallocBytes (size * sizeOf dummy)++-- |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)++-- |Temporarily allocate space for the given number of elements+-- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).+--+allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b+allocaArray  = doAlloca undefined+  where+    doAlloca            :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b'+    doAlloca dummy size  = allocaBytes (size * sizeOf dummy)++-- |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)++-- |Adjust the size of an array+--+reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a)+reallocArray  = doRealloc undefined+  where+    doRealloc                :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a')+    doRealloc dummy ptr size  = reallocBytes ptr (size * sizeOf dummy)++-- |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.  This version+-- traverses the array backwards using an accumulating parameter,+-- which uses constant stack space.  The previous version using mapM+-- needed linear 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 ()+#ifndef __GLASGOW_HASKELL__+pokeArray ptr vals =  zipWithM_ (pokeElemOff ptr) [0..] vals+#else+pokeArray ptr vals0 = go vals0 0#+  where go [] _          = return ()+        go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)+#endif++-- |Write the list elements consecutive into memory and terminate them with the+-- given marker element+--+pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()+#ifndef __GLASGOW_HASKELL__+pokeArray0 marker ptr vals  = do+  pokeArray ptr vals+  pokeElemOff ptr (length vals) marker+#else+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#)+#endif+++-- 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+      res <- f len ptr+      return res+  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+      res <- f len ptr+      return res+  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 :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+copyArray  = doCopy undefined+  where+    doCopy                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()+    doCopy dummy dest src size  = copyBytes dest src (size * sizeOf dummy)++-- |Copy the given number of elements from the second array (source) into the+-- first array (destination); the copied areas /may/ overlap+--+moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()+moveArray  = doMove undefined+  where+    doMove                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()+    doMove dummy dest src size  = moveBytes dest src (size * sizeOf dummy)+++-- 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 :: Storable a => Ptr a -> Int -> Ptr a+advancePtr  = doAdvance undefined+  where+    doAdvance             :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'+    doAdvance dummy ptr i  = ptr `plusPtr` (i * sizeOf dummy)
Foreign/Marshal/Error.hs view
@@ -1,2 +1,83 @@-module Foreign.Marshal.Error (module X___) where-import "base" Foreign.Marshal.Error as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,       -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO a+  throwIf_,      -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO ()+  throwIfNeg,    -- :: (Ord a, Num a) +                 -- =>                (a -> String) -> IO a       -> IO a+  throwIfNeg_,   -- :: (Ord a, Num a)+                 -- =>                (a -> String) -> IO a       -> IO ()+  throwIfNull,   -- ::                String        -> IO (Ptr a) -> IO (Ptr a)++  -- Discard return value+  --+  void           -- IO a -> IO ()+) where++import Foreign.Ptr++#ifdef __GLASGOW_HASKELL__+#ifdef __HADDOCK__+import Data.Bool+import System.IO.Error+#endif+import GHC.Base+import GHC.Num+import GHC.IOBase+#endif++-- 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 ()
Foreign/Marshal/Pool.hs view
@@ -1,2 +1,209 @@-module Foreign.Marshal.Pool (module X___) where-import "base" Foreign.Marshal.Pool as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+--------------------------------------------------------------------------------+-- |+-- 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,             -- :: IO Pool+   freePool,            -- :: Pool -> IO ()+   withPool,            -- :: (Pool -> IO b) -> IO b++   -- * (Re-)Allocation within a pool+   pooledMalloc,        -- :: Storable a => Pool                 -> IO (Ptr a)+   pooledMallocBytes,   -- ::               Pool          -> Int -> IO (Ptr a)++   pooledRealloc,       -- :: Storable a => Pool -> Ptr a        -> IO (Ptr a)+   pooledReallocBytes,  -- ::               Pool -> Ptr a -> Int -> IO (Ptr a)++   pooledMallocArray,   -- :: Storable a => Pool ->          Int -> IO (Ptr a)+   pooledMallocArray0,  -- :: Storable a => Pool ->          Int -> IO (Ptr a)++   pooledReallocArray,  -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+   pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)++   -- * Combined allocation and marshalling+   pooledNew,           -- :: Storable a => Pool -> a            -> IO (Ptr a)+   pooledNewArray,      -- :: Storable a => Pool ->      [a]     -> IO (Ptr a)+   pooledNewArray0      -- :: Storable a => Pool -> a -> [a]     -> IO (Ptr a)+) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base              ( Int, Monad(..), (.), not )+import GHC.Err               ( undefined )+import GHC.Exception         ( throw )+import GHC.IOBase            ( IO, IORef, newIORef, readIORef, writeIORef,+                               block, unblock, catchAny )+import GHC.List              ( elem, length )+import GHC.Num               ( Num(..) )+#else+import Data.IORef            ( IORef, newIORef, readIORef, writeIORef )+#if defined(__NHC__)+import IO                    ( bracket )+#else+import Control.Exception.Base ( bracket )+#endif+#endif++import Control.Monad         ( liftM )+import Data.List             ( 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-H98 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+#ifdef __GLASGOW_HASKELL__+withPool act =   -- ATTENTION: cut-n-paste from Control.Exception below!+   block (do+      pool <- newPool+      val <- catchAny+                (unblock (act pool))+                (\e -> do freePool pool; throw e)+      freePool pool+      return val)+#else+withPool = bracket newPool freePool+#endif++--------------------------------------------------------------------------------++-- | 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 :: Storable a => Pool -> IO (Ptr a)+pooledMalloc = pm undefined+  where+    pm           :: Storable a' => a' -> Pool -> IO (Ptr a')+    pm dummy pool = pooledMallocBytes pool (sizeOf dummy)++-- | 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 :: Storable a => Pool -> Ptr a -> IO (Ptr a)+pooledRealloc = pr undefined+  where+    pr               :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')+    pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)++-- | 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 :: Storable a => Pool -> Int -> IO (Ptr a)+pooledMallocArray = pma undefined+  where+    pma                :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')+    pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)++-- | 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 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)+pooledReallocArray = pra undefined+  where+    pra                ::  Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')+    pra dummy pool ptr size  = pooledReallocBytes pool ptr (size * sizeOf dummy)++-- | 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/Utils.hs view
@@ -1,2 +1,179 @@-module Foreign.Marshal.Utils (module X___) where-import "base" Foreign.Marshal.Utils as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,          -- :: Storable a => a -> (Ptr a -> IO b) -> IO b+  new,           -- :: Storable a => a -> IO (Ptr a)++  -- ** Marshalling of Boolean values (non-zero corresponds to 'True')+  --+  fromBool,      -- :: Num a => Bool -> a+  toBool,        -- :: Num a => a -> Bool++  -- ** Marshalling of Maybe values+  --+  maybeNew,      -- :: (      a -> IO (Ptr a))+                 -- -> (Maybe a -> IO (Ptr a))+  maybeWith,     -- :: (      a -> (Ptr b -> IO c) -> IO c)+                 -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)+  maybePeek,     -- :: (Ptr a -> IO        b )+                 -- -> (Ptr a -> IO (Maybe b))++  -- ** Marshalling lists of storable objects+  --+  withMany,      -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res++  -- ** Haskellish interface to memcpy and memmove+  -- | (argument order: destination, source)+  --+  copyBytes,     -- :: Ptr a -> Ptr a -> Int -> IO ()+  moveBytes,     -- :: Ptr a -> Ptr a -> Int -> IO ()+) where++import Data.Maybe+import Foreign.Ptr              ( Ptr, nullPtr )+import Foreign.Storable         ( Storable(poke) )+import Foreign.C.Types          ( CSize )+import Foreign.Marshal.Alloc    ( malloc, alloca )++#ifdef __GLASGOW_HASKELL__+import GHC.IOBase+import GHC.Real                 ( fromIntegral )+import GHC.Num+import GHC.Base+#endif++#ifdef __NHC__+import Foreign.C.Types          ( CInt(..) )+#endif++-- 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+    res <- f ptr+    return res+++-- 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 :: Num a => a -> Bool+toBool  = (/= 0)+++-- marshalling of Maybe values+-- ---------------------------++-- |Allocate storage and marshall a storable value wrapped into a 'Maybe'+--+-- * the 'nullPtr' is used to represent 'Nothing'+--+maybeNew :: (      a -> IO (Ptr a))+         -> (Maybe a -> IO (Ptr a))+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 -> Ptr a -> Int -> 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 -> Ptr a -> Int -> IO ()+moveBytes dest src size  = do memmove dest src (fromIntegral size)+                              return ()+++-- auxilliary 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/Ptr.hs view
@@ -1,2 +1,154 @@-module Foreign.Ptr (module X___) where-import "base" Foreign.Ptr as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,      -- data Ptr a+    nullPtr,      -- :: Ptr a+    castPtr,      -- :: Ptr a -> Ptr b+    plusPtr,      -- :: Ptr a -> Int -> Ptr b+    alignPtr,     -- :: Ptr a -> Int -> Ptr a+    minusPtr,     -- :: Ptr a -> Ptr b -> Int++    -- * Function pointers++    FunPtr,      -- data FunPtr a+    nullFunPtr,      -- :: FunPtr a+    castFunPtr,      -- :: FunPtr a -> FunPtr b+    castFunPtrToPtr, -- :: FunPtr a -> Ptr b+    castPtrToFunPtr, -- :: Ptr a -> FunPtr b++    freeHaskellFunPtr, -- :: FunPtr a -> IO ()+    -- Free the function pointer created by foreign export dynamic.++#ifndef __NHC__+    -- * Integral types with lossless conversion to and from pointers+    IntPtr,+    ptrToIntPtr,+    intPtrToPtr,+    WordPtr,+    ptrToWordPtr,+    wordPtrToPtr+#endif+ ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Ptr+import GHC.IOBase+import GHC.Base+import GHC.Num+import GHC.Read+import GHC.Real+import GHC.Show+import GHC.Enum+import GHC.Word         ( Word(..) )++import Data.Int+import Data.Word+#else+import Control.Monad    ( liftM )+import Foreign.C.Types+#endif++import Data.Bits+import Data.Typeable+import Foreign.Storable ( Storable(..) )++#ifdef __NHC__+import NHC.FFI+  ( Ptr+  , nullPtr+  , castPtr+  , plusPtr+  , alignPtr+  , minusPtr+  , FunPtr+  , nullFunPtr+  , castFunPtr+  , castFunPtrToPtr+  , castPtrToFunPtr+  , freeHaskellFunPtr+  )+#endif++#ifdef __HUGS__+import Hugs.Ptr+#endif++#ifdef __GLASGOW_HASKELL__+-- | 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 ()+#endif++#ifndef __NHC__+# include "HsBaseConfig.h"+# include "CTypes.h"++# ifdef __GLASGOW_HASKELL__+-- | An unsigned integral type that can be losslessly converted to and from+-- @Ptr@.+INTEGRAL_TYPE(WordPtr,tyConWordPtr,"WordPtr",Word)+        -- Word and Int are guaranteed pointer-sized in GHC++-- | A signed integral type that can be losslessly converted to and from+-- @Ptr@.+INTEGRAL_TYPE(IntPtr,tyConIntPtr,"IntPtr",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#)++# else /* !__GLASGOW_HASKELL__ */++INTEGRAL_TYPE(WordPtr,tyConWordPtr,"WordPtr",CUIntPtr)+INTEGRAL_TYPE(IntPtr,tyConIntPtr,"IntPtr",CIntPtr)++{-# CFILES cbits/PrelIOUtils.c #-}++foreign import ccall unsafe "__hscore_to_uintptr"+    ptrToWordPtr :: Ptr a -> WordPtr++foreign import ccall unsafe "__hscore_from_uintptr"+    wordPtrToPtr :: WordPtr -> Ptr a++foreign import ccall unsafe "__hscore_to_intptr"+    ptrToIntPtr :: Ptr a -> IntPtr++foreign import ccall unsafe "__hscore_from_intptr"+    intPtrToPtr :: IntPtr -> Ptr a++# endif /* !__GLASGOW_HASKELL__ */+#endif /* !__NHC_ */
Foreign/StablePtr.hs view
@@ -1,2 +1,61 @@-module Foreign.StablePtr (module X___) where-import "base" Foreign.StablePtr as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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       -- :: a -> IO (StablePtr a)+        , deRefStablePtr     -- :: StablePtr a -> IO a+        , freeStablePtr      -- :: StablePtr a -> IO ()+        , castStablePtrToPtr -- :: StablePtr a -> Ptr ()+        , castPtrToStablePtr -- :: Ptr () -> StablePtr a+        , -- ** The C-side interface++          -- $cinterface+        ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Stable+#endif++#ifdef __HUGS__+import Hugs.StablePtr+#endif++#ifdef __NHC__+import NHC.FFI+  ( StablePtr+  , newStablePtr+  , deRefStablePtr+  , freeStablePtr+  , castStablePtrToPtr+  , castPtrToStablePtr+  )+#endif++-- $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 view
@@ -1,2 +1,244 @@-module Foreign.Storable (module X___) where-import "base" Foreign.Storable as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,         -- :: a -> Int+             alignment,      -- :: a -> Int+             peekElemOff,    -- :: Ptr a -> Int      -> IO a+             pokeElemOff,    -- :: Ptr a -> Int -> a -> IO ()+             peekByteOff,    -- :: Ptr b -> Int      -> IO a+             pokeByteOff,    -- :: Ptr b -> Int -> a -> IO ()+             peek,           -- :: Ptr a             -> IO a+             poke)           -- :: Ptr a        -> a -> IO ()+        ) where+++#ifdef __NHC__+import NHC.FFI (Storable(..),Ptr,FunPtr,StablePtr+               ,Int8,Int16,Int32,Int64,Word8,Word16,Word32,Word64)+#else++import Control.Monad            ( liftM )++#include "MachDeps.h"+#include "HsBaseConfig.h"++#ifdef __GLASGOW_HASKELL__+import GHC.Storable+import GHC.Stable       ( StablePtr )+import GHC.Num+import GHC.Int+import GHC.Word+import GHC.Ptr+import GHC.Err+import GHC.IOBase+import GHC.Base+#else+import Data.Int+import Data.Word+import Foreign.StablePtr+#endif++#ifdef __HUGS__+import Hugs.Prelude+import Hugs.Ptr+import Hugs.Storable+#endif++{- |+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'.++Minimal complete definition: 'sizeOf', 'alignment', one of 'peek',+'peekElemOff' and 'peekByteOff', and one of 'poke', 'pokeElemOff' and+'pokeByteOff'.+-}++class Storable a where++   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 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+#ifdef __GLASGOW_HASKELL__+   peekElemOff = peekElemOff_ undefined+      where peekElemOff_ :: a -> Ptr a -> Int -> IO a+            peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)+#else+   peekElemOff ptr off = peekByteOff ptr (off * sizeOfPtr ptr undefined)+#endif+   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++#ifndef __GLASGOW_HASKELL__+sizeOfPtr :: Storable a => Ptr a -> a -> Int+sizeOfPtr px x = sizeOf x+#endif++-- System-dependent, but rather obvious instances++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 }++#ifdef __GLASGOW_HASKELL__+STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,+         readWideCharOffPtr,writeWideCharOffPtr)+#elif defined(__HUGS__)+STORABLE(Char,SIZEOF_HSCHAR,ALIGNMENT_HSCHAR,+         readCharOffPtr,writeCharOffPtr)+#endif++STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT,+         readIntOffPtr,writeIntOffPtr)++#ifndef __NHC__+STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD,+         readWordOffPtr,writeWordOffPtr)+#endif++STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR,+         readPtrOffPtr,writePtrOffPtr)++STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR,+         readFunPtrOffPtr,writeFunPtrOffPtr)++STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR,+         readStablePtrOffPtr,writeStablePtrOffPtr)++STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT,+         readFloatOffPtr,writeFloatOffPtr)++STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE,+         readDoubleOffPtr,writeDoubleOffPtr)++STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,+         readWord8OffPtr,writeWord8OffPtr)++STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,+         readWord16OffPtr,writeWord16OffPtr)++STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,+         readWord32OffPtr,writeWord32OffPtr)++STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,+         readWord64OffPtr,writeWord64OffPtr)++STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,+         readInt8OffPtr,writeInt8OffPtr)++STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,+         readInt16OffPtr,writeInt16OffPtr)++STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,+         readInt32OffPtr,writeInt32OffPtr)++STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,+         readInt64OffPtr,writeInt64OffPtr)++#endif
+ Foreign/Storable.hs-boot view
@@ -0,0 +1,22 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module Foreign.Storable where++import GHC.Base+import GHC.Int+import GHC.Word++class Storable a++instance Storable Int8+instance Storable Int16+instance Storable Int32+instance Storable Int64+instance Storable Word8+instance Storable Word16+instance Storable Word32+instance Storable Word64+instance Storable Float+instance Storable Double+
− GHC/Arr.hs 
@@ -1,2 +0,0 @@-module GHC.Arr (module X___) where-import "base" GHC.Arr as X___
+ GHC/Arr.lhs view
@@ -0,0 +1,729 @@+\begin{code}+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# LANGUAGE NoImplicitPrelude, NoBangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- 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 where++import GHC.Enum+import GHC.Num+import GHC.ST+import GHC.Base+import GHC.List+import GHC.Show++infixl 9  !, //++default ()+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Ix@ class}+%*                                                      *+%*********************************************************++\begin{code}+-- | 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))@+--+-- Minimal complete instance: 'range', 'index' and 'inRange'.+--+class (Ord a) => Ix a where+    -- | 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 b i | inRange b i = unsafeIndex b i   +              | otherwise   = error "Error in array index"+    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+\end{code}++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++%*********************************************************+%*                                                      *+\subsection{Instances of @Ix@}+%*                                                      *+%*********************************************************++\begin{code}+-- 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+  = error (showString "Ix{" . showString tp . showString "}.index: Index " .+           showParen True (showsPrec 0 i) .+           showString " out of range " $+           showParen True (showsPrec 0 rng) "")++----------------------------------------------------------------------+instance  Ix Char  where+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (m,_n) i = fromEnum i - fromEnum m++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Char"++    inRange (m,n) i     =  m <= i && i <= n++----------------------------------------------------------------------+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++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Int"++    {-# INLINE inRange #-}+    inRange (I# m,I# n) (I# i) =  m <=# i && i <=# n++----------------------------------------------------------------------+instance  Ix Integer  where+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (m,_n) i   = fromInteger (i - m)++    index b i | inRange b i =  unsafeIndex b i+              | otherwise   =  indexError b i "Integer"++    inRange (m,n) i     =  m <= i && i <= n++----------------------------------------------------------------------+instance Ix Bool where -- as derived+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (l,_) i = fromEnum i - fromEnum l++    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++----------------------------------------------------------------------+instance Ix Ordering where -- as derived+    {-# INLINE range #-}+    range (m,n) = [m..n]++    {-# INLINE unsafeIndex #-}+    unsafeIndex (l,_) i = fromEnum i - fromEnum l++    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++----------------------------------------------------------------------+instance Ix () where+    {-# INLINE range #-}+    range   ((), ())    = [()]+    {-# INLINE unsafeIndex #-}+    unsafeIndex   ((), ()) () = 0+    {-# INLINE inRange #-}+    inRange ((), ()) () = True+    {-# INLINE index #-}+    index b i = unsafeIndex b i++----------------------------------------------------------------------+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++----------------------------------------------------------------------+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++----------------------------------------------------------------------+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++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+\end{code}++%*********************************************************+%*                                                      *+\subsection{The @Array@ types}+%*                                                      *+%*********************************************************++\begin{code}+type IPr = (Int, Int)++-- | The type of immutable non-strict (boxed) arrays+-- with indices in @i@ and elements in @e@.+-- The Int is the number of elements in the Array.+data Ix i => Array i e+                 = Array !i         -- the lower bound, l+                         !i         -- the upper bound, u+                         !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+                   !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.++-- Just pointer equality on mutable arrays:+instance Eq (STArray s i e) where+    STArray _ _ _ arr1# == STArray _ _ _ arr2# =+        sameMutableArray# arr1# arr2#+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Operations on immutable arrays}+%*                                                      *+%*********************************************************++\begin{code}+{-# NOINLINE arrEleBottom #-}+arrEleBottom :: a+arrEleBottom = error "(Array.!): undefined array element"++{-# INLINE array #-}+-- | 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 98 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 nonstrict 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.+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' :: Ix i => (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+fill marr# (I# i#, e) next s1# =+    case writeArray# marr# i# e s1#     of { s2# ->+    next s2# }++{-# INLINE done #-}+done :: Ix i => i -> i -> Int -> MutableArray# s e -> STRep s (Array i e)+done l u n marr# s1# =+    case unsafeFreezeArray# marr# s1# of+        (# s2#, arr# #) -> (# s2#, Array l u n arr# #)++-- This is inefficient and I'm not sure why:+-- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)+-- The code below is better. It still doesn't enable foldr/build+-- transformation on the list of elements; I guess it's impossible+-- using mechanisms currently available.++{-# INLINE listArray #-}+-- | Construct an array from a pair of bounds and a list of values in+-- index order.+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 fillFromList i# xs s3# | i# ==# n# = s3#+                               | otherwise = case xs of+            []   -> s3#+            y:ys -> case writeArray# marr# i# y s3# of { s4# ->+                    fillFromList (i# +# 1#) ys s4# } in+    case fillFromList 0# es s2#         of { s3# ->+    done l u n marr# s3# }}})++{-# INLINE (!) #-}+-- | The value at the given index in an array.+(!) :: 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 error "Negative range size"+                                  else r++{-# INLINE safeIndex #-}+safeIndex :: Ix i => (i, i) -> Int -> i -> Int+safeIndex (l,u) n i = let i' = unsafeIndex (l,u) i+                      in if (0 <= i') && (i' < n)+                         then i'+                         else error "Error in array index"++{-# INLINE unsafeAt #-}+unsafeAt :: Ix i => Array i e -> Int -> e+unsafeAt (Array _ _ _ arr#) (I# i#) =+    case indexArray# arr# i# of (# e #) -> e++{-# INLINE bounds #-}+-- | The bounds with which an array was constructed.+bounds :: Ix i => Array i e -> (i,i)+bounds (Array l u _ _) = (l,u)++{-# INLINE numElements #-}+-- | The number of elements in the array.+numElements :: Ix i => Array i e -> Int+numElements (Array _ _ n _) = n++{-# INLINE indices #-}+-- | The list of indices of an array in ascending order.+indices :: Ix i => Array i e -> [i]+indices (Array l u _ _) = range (l,u)++{-# INLINE elems #-}+-- | The list of elements of an array in index order.+elems :: Ix i => Array i e -> [e]+elems arr@(Array _ _ n _) =+    [unsafeAt arr i | i <- [0 .. n - 1]]++{-# INLINE assocs #-}+-- | The list of associations of an array in index order.+assocs :: Ix i => Array i e -> [(i, e)]+assocs arr@(Array l u _ _) =+    [(i, arr ! i) | i <- range (l,u)]++{-# INLINE accumArray #-}+-- | The 'accumArray' 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]+--+-- If the accumulating function is strict, then 'accumArray' is strict in+-- the values, as well as the indices, in the association list.  Thus,+-- unlike ordinary arrays built with 'array', accumulated arrays should+-- not in general be recursive.+accumArray :: 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' :: Ix i => (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+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 (//) #-}+-- | 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 98 specifies that the resulting array is undefined (i.e. bottom),+-- but GHC's implementation uses the last association for each index.+(//) :: 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 :: Ix i => 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))++{-# INLINE accum #-}+-- | @'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 :: 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 :: Ix i => (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 amap #-}+amap :: Ix i => (a -> b) -> Array i a -> Array i b+amap f arr@(Array l u n _) =+    unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]]++{-# INLINE ixmap #-}+-- | '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.+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 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 #-}+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Array instances}+%*                                                      *+%*********************************************************++\begin{code}+instance Ix i => Functor (Array i) where+    fmap = amap++instance (Ix i, Eq e) => Eq (Array i e) where+    (==) = eqArray++instance (Ix i, Ord e) => Ord (Array i e) where+    compare = cmpArray++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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{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.++\begin{code}+{-# 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 :: Ix i => 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 :: Ix i => 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#, () #)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Moving between mutable and immutable}+%*                                                      *+%*********************************************************++\begin{code}+freezeSTArray :: Ix i => 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# | 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 :: Ix i => STArray s i e -> ST s (Array i e)+unsafeFreezeSTArray (STArray l u n marr#) = ST $ \s1# ->+    case unsafeFreezeArray# marr# s1#   of { (# s2#, arr# #) ->+    (# s2#, Array l u n arr# #) }++thawSTArray :: Ix i => Array i e -> ST s (STArray s i e)+thawSTArray (Array l u n@(I# n#) arr#) = ST $ \s1# ->+    case newArray# n# arrEleBottom s1#  of { (# s2#, marr# #) ->+    let copy i# s3# | 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 :: Ix i => 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# #) }+\end{code}
− GHC/Base.hs 
@@ -1,2 +0,0 @@-module GHC.Base (module X___) where-import "base" GHC.Base as X___
+ GHC/Base.lhs view
@@ -0,0 +1,1009 @@+\section[GHC.Base]{Module @GHC.Base@}++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 intances 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.++\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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"++-- #hide+module GHC.Base+        (+        module GHC.Base,+        module GHC.Bool,+        module GHC.Classes,+        module GHC.Generics,+        module GHC.Ordering,+        module GHC.Types,+        module GHC.Prim,        -- Re-export GHC.Prim and GHC.Err, to avoid lots+        module GHC.Err          -- of people having to import it explicitly+  ) +        where++import GHC.Types+import GHC.Bool+import GHC.Classes+import GHC.Generics+import GHC.Ordering+import GHC.Prim+import {-# SOURCE #-} GHC.Err++infixr 9  .+infixr 5  +++infixl 1  >>, >>=+infixr 0  $++default ()              -- Double isn't available yet+\end{code}+++%*********************************************************+%*                                                      *+\subsection{DEBUGGING STUFF}+%*  (for use when compiling GHC.Base itself doesn't work)+%*                                                      *+%*********************************************************++\begin{code}+{-+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 = error "urk"+foldr = error "urk"++unpackCString# :: Addr# -> [Char]+unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a +unpackAppendCString# :: Addr# -> [Char] -> [Char]+unpackCStringUtf8# :: Addr# -> [Char]+unpackCString# a = error "urk"+unpackFoldrCString# a = error "urk"+unpackAppendCString# a = error "urk"+unpackCStringUtf8# a = error "urk"+-}+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Monadic classes @Functor@, @Monad@ }+%*                                                      *+%*********************************************************++\begin{code}+{- | The 'Functor' class is used for types that can be mapped over.+Instances of 'Functor' should satisfy the following laws:++> fmap id  ==  id+> fmap (f . g)  ==  fmap f . fmap g++The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+defined in the "Prelude" satisfy these laws.+-}++class  Functor f  where+    fmap        :: (a -> b) -> f a -> f b++{- | 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.++Minimal complete definition: '>>=' and 'return'.++Instances of 'Monad' should satisfy the following laws:++> return a >>= k  ==  k a+> m >>= return  ==  m+> m >>= (\x -> k x >>= h)  ==  (m >>= k) >>= h++Instances of both 'Monad' and 'Functor' should additionally satisfy the law:++> fmap f xs  ==  xs >>= return . f++The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'+defined in the "Prelude" satisfy these laws.+-}++class  Monad m  where+    -- | Sequentially compose two actions, passing any value produced+    -- by the first as an argument to the second.+    (>>=)       :: 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.+    (>>)        :: forall a b. m a -> m b -> m b+        -- Explicit for-alls so that we know what order to+        -- give type arguments when desugaring++    -- | Inject a value into the monadic type.+    return      :: a -> m a+    -- | Fail with a message.  This operation is not part of the+    -- mathematical definition of a monad, but is invoked on pattern-match+    -- failure in a @do@ expression.+    fail        :: String -> m a++    m >> k      = m >>= \_ -> k+    fail s      = error s+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The list type}+%*                                                      *+%*********************************************************++\begin{code}+-- do explicitly: deriving (Eq, Ord)+-- to avoid weird names like con2tag_[]#++instance (Eq a) => Eq [a] where+    {-# SPECIALISE instance Eq [Char] #-}+    []     == []     = True+    (x:xs) == (y:ys) = x == y && xs == ys+    _xs    == _ys    = False++instance (Ord a) => Ord [a] where+    {-# SPECIALISE instance Ord [Char] #-}+    compare []     []     = EQ+    compare []     (_:_)  = LT+    compare (_:_)  []     = GT+    compare (x:xs) (y:ys) = case compare x y of+                                EQ    -> compare xs ys+                                other -> other++instance Functor [] where+    fmap = map++instance  Monad []  where+    m >>= k             = foldr ((++) . k) [] m+    m >> k              = foldr ((++) . (\ _ -> k)) [] m+    return x            = [x]+    fail _              = []+\end{code}++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+----------------------------------------------+  +\begin{code}+-- | '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+foldr k z xs = go xs+             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 ++"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+\end{code}+++----------------------------------------------+--              map     +----------------------------------------------++\begin{code}+-- | '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 :: (a -> b) -> [a] -> [b]+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 #-}+mapFB c f x ys = c (f x) ys++-- 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.+--+-- The "mapFB" rule optimises compositions of map.+--+-- This same pattern is followed by many other functions: +-- e.g. append, filter, iterate, repeat, etc.++{-# 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) +  #-}+\end{code}+++----------------------------------------------+--              append  +----------------------------------------------+\begin{code}+-- | 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]+(++) []     ys = ys+(++) (x:xs) ys = x : xs ++ ys++{-# RULES+"++"    [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys+  #-}++\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Bool@}+%*                                                      *+%*********************************************************++\begin{code}+-- |The 'Bool' type is an enumeration.  It is defined with 'False'+-- first so that the corresponding 'Prelude.Enum' instance will give+-- 'Prelude.fromEnum' 'False' the value zero, and+-- 'Prelude.fromEnum' 'True' the value 1.+-- The actual definition is in the ghc-prim package.++-- XXX These don't work:+-- deriving instance Eq Bool+-- deriving instance Ord Bool+-- <wired into compiler>:+--     Illegal binding of built-in syntax: con2tag_Bool#++instance Eq Bool where+    True  == True  = True+    False == False = True+    _     == _     = False++instance Ord Bool where+    compare False True  = LT+    compare True  False = GT+    compare _     _     = EQ++-- Read is in GHC.Read, Show in GHC.Show++-- |'otherwise' is defined as the value 'True'.  It helps to make+-- guards more readable.  eg.+--+-- >  f x | x < 0     = ...+-- >      | otherwise = ...+otherwise               :: Bool+otherwise               =  True+\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Ordering@}+%*                                                      *+%*********************************************************++\begin{code}+-- | Represents an ordering relationship between two values: less+-- than, equal to, or greater than.  An 'Ordering' is returned by+-- 'compare'.+-- XXX These don't work:+-- deriving instance Eq Ordering+-- deriving instance Ord Ordering+-- Illegal binding of built-in syntax: con2tag_Ordering#+instance Eq Ordering where+    EQ == EQ = True+    LT == LT = True+    GT == GT = True+    _  == _  = False+        -- Read in GHC.Read, Show in GHC.Show++instance Ord Ordering where+    LT <= _  = True+    _  <= LT = False+    EQ <= _  = True+    _  <= EQ = False+    GT <= GT = True+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Char@ and @String@}+%*                                                      *+%*********************************************************++\begin{code}+-- | A 'String' is a list of characters.  String constants in Haskell are values+-- of type 'String'.+--+type String = [Char]++{-| The character type 'Char' is an enumeration whose values represent+Unicode (or equivalently ISO\/IEC 10646) characters+(see <http://www.unicode.org/> for details).+This set extends the ISO 8859-1 (Latin-1) character set+(the first 256 charachers), which is itself an extension of the ASCII+character set (the first 128 characters).+A character literal in Haskell has type 'Char'.++To convert a 'Char' to or from the corresponding 'Int' value defined+by Unicode, use 'Prelude.toEnum' and 'Prelude.fromEnum' from the+'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr').+-}++-- We don't use deriving for Eq and Ord, because for Ord the derived+-- instance defines only compare, which takes two primops.  Then+-- '>' uses compare, and therefore takes two primops instead of one.++instance Eq Char where+    (C# c1) == (C# c2) = c1 `eqChar#` c2+    (C# c1) /= (C# c2) = c1 `neChar#` c2++instance Ord Char where+    (C# c1) >  (C# c2) = c1 `gtChar#` c2+    (C# c1) >= (C# c2) = c1 `geChar#` c2+    (C# c1) <= (C# c2) = c1 `leChar#` c2+    (C# c1) <  (C# c2) = c1 `ltChar#` c2++{-# RULES+"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True+"x# `neChar#` x#" forall x#. x# `neChar#` x# = False+"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False+"x# `geChar#` x#" forall x#. x# `geChar#` x# = True+"x# `leChar#` x#" forall x#. x# `leChar#` x# = True+"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False+  #-}++-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.+chr :: Int -> Char+chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)+            | otherwise                                  = error "Prelude.chr: bad argument"++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#)+\end{code}++String equality is used when desugaring pattern-matches against strings.++\begin{code}+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 PrelRules.lhs:+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Int@}+%*                                                      *+%*********************************************************++\begin{code}+zeroInt, oneInt, twoInt, maxInt, minInt :: Int+zeroInt = I# 0#+oneInt  = I# 1#+twoInt  = I# 2#++{- 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++instance Eq Int where+    (==) = eqInt+    (/=) = neInt++instance Ord Int where+    compare = compareInt+    (<)     = ltInt+    (<=)    = leInt+    (>=)    = geInt+    (>)     = gtInt++compareInt :: Int -> Int -> Ordering+(I# x#) `compareInt` (I# y#) = compareInt# x# y#++compareInt# :: Int# -> Int# -> Ordering+compareInt# x# y#+    | x# <#  y# = LT+    | x# ==# y# = EQ+    | otherwise = GT+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The function type}+%*                                                      *+%*********************************************************++\begin{code}+-- | Identity function.+id                      :: a -> a+id x                    =  x++-- | The call '(lazy e)' means the same as 'e', but 'lazy' has a +-- magical strictness property: it is lazy in its first argument, +-- even though its semantics is strict.+lazy :: a -> a+lazy x = x+-- Implementation note: its strictness and unfolding are over-ridden+-- by the definition in MkId.lhs; in both cases to nothing at all.+-- That way, 'lazy' does not get inlined, and the strictness analyser+-- sees it as lazy.  Then the worker/wrapper phase inlines it.+-- Result: happiness+++-- | The call '(inline f)' reduces to 'f', but 'inline' has a BuiltInRule+-- that tries to inline 'f' (if it has an unfolding) unconditionally+-- The 'NOINLINE' pragma arranges that inline only gets inlined (and+-- hence eliminated) late in compilation, after the rule has had+-- a god chance to fire.+inline :: a -> a+{-# NOINLINE[0] inline #-}+inline 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 '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.lhs+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++-- | Constant function.+const                   :: a -> b -> a+const x _               =  x++-- | Function composition.+{-# INLINE (.) #-}+(.)       :: (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                    :: (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@.+{-# INLINE ($) #-}+($)                     :: (a -> b) -> a -> b+f $ x                   =  f x++-- | @'until' p f@ yields the result of applying @f@ until @p@ holds.+until                   :: (a -> Bool) -> (a -> a) -> a -> a+until p f x | p x       =  x+            | otherwise =  until p f (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+\end{code}++%*********************************************************+%*                                                      *+\subsection{@getTag@}+%*                                                      *+%*********************************************************++Returns the 'tag' of a constructor application; this function is used+by the deriving code for Eq, Ord and Enum.++The primitive dataToTag# requires an evaluated constructor application+as its argument, so we provide getTag as a wrapper that performs the+evaluation before calling dataToTag#.  We could have dataToTag#+evaluate its argument, but we prefer to do it this way because (a)+dataToTag# can be an inline primop if it doesn't need to do any+evaluation, and (b) we want to expose the evaluation to the+simplifier, because it might be possible to eliminate the evaluation+in the case when the argument is already known to be evaluated.++\begin{code}+{-# INLINE getTag #-}+getTag :: a -> Int#+getTag x = x `seq` dataToTag# x+\end{code}++%*********************************************************+%*                                                      *+\subsection{Numeric primops}+%*                                                      *+%*********************************************************++\begin{code}+divInt# :: Int# -> Int# -> Int#+x# `divInt#` y#+        -- Be careful NOT to overflow if we do any additional arithmetic+        -- on the arguments...  the following  previous version of this+        -- code has problems with overflow:+--    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#+--    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#+    | (x# ># 0#) && (y# <# 0#) = ((x# -# 1#) `quotInt#` y#) -# 1#+    | (x# <# 0#) && (y# ># 0#) = ((x# +# 1#) `quotInt#` y#) -# 1#+    | otherwise                = x# `quotInt#` y#++modInt# :: Int# -> Int# -> Int#+x# `modInt#` y#+    | (x# ># 0#) && (y# <# 0#) ||+      (x# <# 0#) && (y# ># 0#)    = if r# /=# 0# then r# +# y# else 0#+    | otherwise                   = r#+    where+    r# = x# `remInt#` y#+\end{code}++Definitions of the boxed PrimOps; these will be+used in the case of partial applications, etc.++\begin{code}+{-# INLINE eqInt #-}+{-# INLINE neInt #-}+{-# INLINE gtInt #-}+{-# INLINE geInt #-}+{-# INLINE ltInt #-}+{-# INLINE leInt #-}+{-# INLINE plusInt #-}+{-# INLINE minusInt #-}+{-# INLINE timesInt #-}+{-# INLINE quotInt #-}+{-# INLINE remInt #-}+{-# INLINE negateInt #-}++plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int+(I# x) `plusInt`  (I# y) = I# (x +# y)+(I# x) `minusInt` (I# y) = I# (x -# y)+(I# x) `timesInt` (I# y) = I# (x *# y)+(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)++{-# RULES+"x# +# 0#" forall x#. x# +# 0# = x#+"0# +# x#" forall x#. 0# +# x# = x#+"x# -# 0#" forall x#. x# -# 0# = x#+"x# -# x#" forall x#. x# -# x# = 0#+"x# *# 0#" forall x#. x# *# 0# = 0#+"0# *# x#" forall x#. 0# *# x# = 0#+"x# *# 1#" forall x#. x# *# 1# = x#+"1# *# x#" forall x#. 1# *# x# = x#+  #-}++gcdInt (I# a) (I# b) = g a b+   where g 0# 0# = error "GHC.Base.gcdInt: gcd 0 0 is undefined"+         g 0# _  = I# absB+         g _  0# = I# absA+         g _  _  = I# (gcdInt# absA absB)++         absInt x = if x <# 0# then negateInt# x else x++         absA     = absInt a+         absB     = absInt b++negateInt :: Int -> Int+negateInt (I# x) = I# (negateInt# x)++gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool+(I# x) `gtInt` (I# y) = x >#  y+(I# x) `geInt` (I# y) = x >=# y+(I# x) `eqInt` (I# y) = x ==# y+(I# x) `neInt` (I# y) = x /=# y+(I# x) `ltInt` (I# y) = x <#  y+(I# x) `leInt` (I# y) = x <=# y++{-# RULES+"x# ># x#"  forall x#. x# >#  x# = False+"x# >=# x#" forall x#. x# >=# x# = True+"x# ==# x#" forall x#. x# ==# x# = True+"x# /=# x#" forall x#. x# /=# x# = False+"x# <# x#"  forall x#. x# <#  x# = False+"x# <=# x#" forall x#. x# <=# x# = True+  #-}++{-# RULES+"plusFloat x 0.0"   forall x#. plusFloat#  x#   0.0# = x#+"plusFloat 0.0 x"   forall x#. plusFloat#  0.0# x#   = x#+"minusFloat x 0.0"  forall x#. minusFloat# x#   0.0# = x#+"minusFloat x x"    forall x#. minusFloat# x#   x#   = 0.0#+"timesFloat x 0.0"  forall x#. timesFloat# x#   0.0# = 0.0#+"timesFloat0.0 x"   forall x#. timesFloat# 0.0# x#   = 0.0#+"timesFloat x 1.0"  forall x#. timesFloat# x#   1.0# = x#+"timesFloat 1.0 x"  forall x#. timesFloat# 1.0# x#   = x#+"divideFloat x 1.0" forall x#. divideFloat# x#  1.0# = x#+  #-}++{-# RULES+"plusDouble x 0.0"   forall x#. (+##) x#    0.0## = x#+"plusDouble 0.0 x"   forall x#. (+##) 0.0## x#    = x#+"minusDouble x 0.0"  forall x#. (-##) x#    0.0## = x#+"timesDouble x 1.0"  forall x#. (*##) x#    1.0## = x#+"timesDouble 1.0 x"  forall x#. (*##) 1.0## x#    = x#+"divideDouble x 1.0" forall x#. (/##) x#    1.0## = x#+  #-}++{-+We'd like to have more rules, but for example:++This gives wrong answer (0) for NaN - NaN (should be NaN):+    "minusDouble x x"    forall x#. (-##) x#    x#    = 0.0##++This gives wrong answer (0) for 0 * NaN (should be NaN):+    "timesDouble 0.0 x"  forall x#. (*##) 0.0## x#    = 0.0##++This gives wrong answer (0) for NaN * 0 (should be NaN):+    "timesDouble x 0.0"  forall x#. (*##) x#    0.0## = 0.0##++These are tested by num014.+-}++-- 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   | b >=# WORD_SIZE_IN_BITS# = int2Word# 0#+                | otherwise                = a `uncheckedShiftL#` b++-- | Shift the argument right by the specified number of bits+-- (which must be non-negative).+shiftRL# :: Word# -> Int# -> Word#+a `shiftRL#` b  | b >=# WORD_SIZE_IN_BITS# = int2Word# 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  | 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).+iShiftRA# :: Int# -> Int# -> Int#+a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if 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).+iShiftRL# :: Int# -> Int# -> Int#+a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0#+                | otherwise                = a `uncheckedIShiftRL#` b++#if WORD_SIZE_IN_BITS == 32+{-# RULES+"narrow32Int#"  forall x#. narrow32Int#   x# = x#+"narrow32Word#" forall x#. narrow32Word#   x# = x#+   #-}+#endif++{-# RULES+"int2Word2Int"  forall x#. int2Word# (word2Int# x#) = x#+"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#+  #-}+\end{code}+++%********************************************************+%*                                                      *+\subsection{Unpacking C strings}+%*                                                      *+%********************************************************++This code is needed for virtually all programs, since it's used for+unpacking the strings of error messages.++\begin{code}+unpackCString# :: Addr# -> [Char]+{-# NOINLINE [1] unpackCString# #-}+unpackCString# addr +  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'# = []+      | otherwise          = C# ch : unpack (nh +# 1#)+      where+        ch = indexCharOffAddr# addr nh++unpackAppendCString# :: Addr# -> [Char] -> [Char]+unpackAppendCString# addr rest+  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'# = rest+      | otherwise          = C# ch : unpack (nh +# 1#)+      where+        ch = indexCharOffAddr# addr nh++unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a +{-# NOINLINE [0] unpackFoldrCString# #-}+-- Don't inline till right at the end;+-- usually the unpack-list rule turns it into unpackCStringList+-- It also has a BuiltInRule in PrelRules.lhs:+--      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)+--        =  unpackFoldrCString# "foobaz" c n+unpackFoldrCString# addr f z +  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'# = z+      | otherwise          = C# ch `f` unpack (nh +# 1#)+      where+        ch = indexCharOffAddr# addr nh++unpackCStringUtf8# :: Addr# -> [Char]+unpackCStringUtf8# addr +  = unpack 0#+  where+    unpack nh+      | ch `eqChar#` '\0'#   = []+      | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)+      | ch `leChar#` '\xDF'# =+          C# (chr# (((ord# ch                                  -# 0xC0#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :+          unpack (nh +# 2#)+      | ch `leChar#` '\xEF'# =+          C# (chr# (((ord# ch                                  -# 0xE0#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :+          unpack (nh +# 3#)+      | otherwise            =+          C# (chr# (((ord# ch                                  -# 0xF0#) `uncheckedIShiftL#` 18#) +#+                    ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#+                    ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#`  6#) +#+                     (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :+          unpack (nh +# 4#)+      where+        ch = indexCharOffAddr# addr nh++unpackNBytes# :: Addr# -> Int# -> [Char]+unpackNBytes# _addr 0#   = []+unpackNBytes#  addr len# = unpack [] (len# -# 1#)+    where+     unpack acc i#+      | i# <# 0#  = acc+      | otherwise = +         case indexCharOffAddr# addr i# of+            ch -> unpack (C# ch : acc) (i# -# 1#)++{-# 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++-- There's a built-in rule (in PrelRules.lhs) for+--      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n++  #-}+\end{code}++#ifdef __HADDOCK__+\begin{code}+-- | A special argument for the 'Control.Monad.ST.ST' type constructor,+-- indexing a state embedded in the 'Prelude.IO' monad by+-- 'Control.Monad.ST.stToIO'.+data RealWorld+\end{code}+#endif
+ GHC/Classes.hs view
@@ -0,0 +1,93 @@++{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Classes+-- 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 classes.+--+-----------------------------------------------------------------------------++module GHC.Classes where++import GHC.Bool+import GHC.Ordering++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||++default ()              -- Double isn't available yet++-- | The 'Eq' class defines equality ('==') and inequality ('/=').+-- All the basic datatypes exported by the "Prelude" are instances of 'Eq',+-- and 'Eq' may be derived for any datatype whose constituents are also+-- instances of 'Eq'.+--+-- Minimal complete definition: either '==' or '/='.+--+class  Eq a  where+    (==), (/=)           :: a -> a -> Bool++    x /= y               = not (x == y)+    x == y               = not (x /= y)++-- | The 'Ord' class is used for totally ordered datatypes.+--+-- Instances of 'Ord' can be derived for any user-defined+-- datatype whose constituent types are in 'Ord'.  The declared order+-- of the constructors in the data declaration determines the ordering+-- in derived 'Ord' instances.  The 'Ordering' datatype allows a single+-- comparison to determine the precise ordering of two objects.+--+-- Minimal complete definition: either 'compare' or '<='.+-- Using 'compare' can be more efficient for complex types.+--+class  (Eq a) => Ord a  where+    compare              :: a -> a -> Ordering+    (<), (<=), (>), (>=) :: a -> a -> Bool+    max, min             :: a -> a -> a++    compare x y = if x == y then EQ+                  -- NB: must be '<=' not '<' to validate the+                  -- above claim about the minimal things that+                  -- can be defined for an instance of Ord:+                  else if x <= y then LT+                  else GT++    x <  y = case compare x y of { LT -> True;  _ -> False }+    x <= y = case compare x y of { GT -> False; _ -> True }+    x >  y = case compare x y of { GT -> True;  _ -> False }+    x >= y = case compare x y of { LT -> False; _ -> True }++        -- These two default methods use '<=' rather than 'compare'+        -- because the latter is often more expensive+    max x y = if x <= y then y else x+    min x y = if x <= y then x else y++-- OK, so they're technically not part of a class...:++-- Boolean functions++-- | Boolean \"and\"+(&&)                    :: Bool -> Bool -> Bool+True  && x              =  x+False && _              =  False++-- | Boolean \"or\"+(||)                    :: Bool -> Bool -> Bool+True  || _              =  True+False || x              =  x++-- | Boolean \"not\"+not                     :: Bool -> Bool+not True                =  False+not False               =  True+
− GHC/Conc.hs 
@@ -1,2 +0,0 @@-module GHC.Conc (module X___) where-import "base" GHC.Conc as X___
+ GHC/Conc.lhs view
@@ -0,0 +1,1309 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-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:++#include "Typeable.h"++-- #not-home+module GHC.Conc+        ( ThreadId(..)++        -- * Forking and suchlike+        , forkIO        -- :: IO a -> IO ThreadId+        , forkOnIO      -- :: Int -> IO a -> IO ThreadId+        , numCapabilities -- :: Int+        , childHandler  -- :: Exception -> IO ()+        , myThreadId    -- :: IO ThreadId+        , killThread    -- :: ThreadId -> IO ()+        , throwTo       -- :: ThreadId -> Exception -> IO ()+        , par           -- :: a -> b -> b+        , pseq          -- :: a -> b -> b+        , yield         -- :: IO ()+        , labelThread   -- :: ThreadId -> String -> IO ()++        , ThreadStatus(..), BlockReason(..)+        , threadStatus  -- :: ThreadId -> IO ThreadStatus++        -- * Waiting+        , threadDelay           -- :: Int -> IO ()+        , registerDelay         -- :: Int -> IO (TVar Bool)+        , threadWaitRead        -- :: Int -> IO ()+        , threadWaitWrite       -- :: Int -> IO ()++        -- * MVars+        , MVar(..)+        , newMVar       -- :: a -> IO (MVar a)+        , newEmptyMVar  -- :: IO (MVar a)+        , takeMVar      -- :: MVar a -> IO a+        , putMVar       -- :: MVar a -> a -> IO ()+        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)+        , tryPutMVar    -- :: MVar a -> a -> IO Bool+        , isEmptyMVar   -- :: MVar a -> IO Bool+        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()++        -- * TVars+        , STM(..)+        , atomically    -- :: STM a -> IO a+        , retry         -- :: STM a+        , orElse        -- :: STM a -> STM a -> STM a+        , catchSTM      -- :: STM a -> (Exception -> STM a) -> STM a+        , alwaysSucceeds -- :: STM a -> STM ()+        , always        -- :: STM Bool -> STM ()+        , TVar(..)+        , newTVar       -- :: a -> STM (TVar a)+        , newTVarIO     -- :: a -> STM (TVar a)+        , readTVar      -- :: TVar a -> STM a+        , writeTVar     -- :: a -> TVar a -> STM ()+        , unsafeIOToSTM -- :: IO a -> STM a++        -- * Miscellaneous+#ifdef mingw32_HOST_OS+        , asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)+        , asyncWrite    -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)+        , asyncDoProc   -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int++        , asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)+        , asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)+#endif++#ifndef mingw32_HOST_OS+        , signalHandlerLock+#endif++        , ensureIOManagerIsRunning++#ifdef mingw32_HOST_OS+        , ConsoleEvent(..)+        , win32ConsoleHandler+        , toWin32ConsoleEvent+#endif+        , setUncaughtExceptionHandler      -- :: (Exception -> IO ()) -> IO ()+        , getUncaughtExceptionHandler      -- :: IO (Exception -> IO ())++        , reportError, reportStackOverflow+        ) where++import System.Posix.Types+#ifndef mingw32_HOST_OS+import System.Posix.Internals+#endif+import Foreign+import Foreign.C++import Data.Maybe++import GHC.Base+import {-# SOURCE #-} GHC.Handle+import GHC.IOBase+import GHC.Num          ( Num(..) )+import GHC.Real         ( fromIntegral )+#ifdef mingw32_HOST_OS+import GHC.Real         ( div )+import GHC.Ptr          ( plusPtr, FunPtr(..) )+#endif+#ifdef mingw32_HOST_OS+import GHC.Read         ( Read )+import GHC.Enum         ( Enum )+#endif+import GHC.Exception    ( SomeException(..), throw )+import GHC.Pack         ( packCString# )+import GHC.Ptr          ( Ptr(..) )+import GHC.STRef+import GHC.Show         ( Show(..), showString )+import Data.Typeable+import GHC.Err++infixr 0 `par`, `pseq`+\end{code}++%************************************************************************+%*                                                                      *+\subsection{@ThreadId@, @par@, and @fork@}+%*                                                                      *+%************************************************************************++\begin{code}+data ThreadId = ThreadId ThreadId# deriving( Typeable )+-- 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.++/Note/: Hugs does not provide any operations on other threads;+it defines 'ThreadId' as a synonym for ().+-}++instance Show ThreadId where+   showsPrec d t = +        showString "ThreadId " . +        showsPrec d (getThreadId (id2TSO t))++foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt++id2TSO :: ThreadId -> ThreadId#+id2TSO (ThreadId t) = t++foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt+-- Returns -1, 0, 1++cmpThread :: ThreadId -> ThreadId -> Ordering+cmpThread t1 t2 = +   case cmp_thread (id2TSO t1) (id2TSO t2) of+      -1 -> LT+      0  -> EQ+      _  -> GT -- must be 1++instance Eq ThreadId where+   t1 == t2 = +      case t1 `cmpThread` t2 of+         EQ -> True+         _  -> False++instance Ord ThreadId where+   compare = cmpThread++{- |+Sparks off 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 thread; if you want to use a foreign+library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.++GHC note: the new thread inherits the /blocked/ state of the parent +(see 'Control.Exception.block').++The newly created thread has an exception handler that discards the+exceptions 'BlockedOnDeadMVar', 'BlockedIndefinitely', and+'ThreadKilled', and passes all other exceptions to the uncaught+exception handler (see 'setUncaughtExceptionHandler').+-}+forkIO :: IO () -> IO ThreadId+forkIO action = IO $ \ s -> +   case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)+ where+  action_plus = catchException action childHandler++{- |+Like 'forkIO', but lets you specify on which CPU the thread is+created.  Unlike a `forkIO` thread, a thread created by `forkOnIO`+will stay on the same CPU for its entire lifetime (`forkIO` threads+can migrate between CPUs according to the scheduling policy).+`forkOnIO` is useful for overriding the scheduling policy when you+know in advance how best to distribute the threads.++The `Int` argument specifies the CPU number; it is interpreted modulo+'numCapabilities' (note that it actually specifies a capability number+rather than a CPU number, but to a first approximation the two are+equivalent).+-}+forkOnIO :: Int -> IO () -> IO ThreadId+forkOnIO (I# cpu) action = IO $ \ s -> +   case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)+ where+  action_plus = catchException action childHandler++-- | 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 CPU cores on+-- the machine.+numCapabilities :: Int+numCapabilities = unsafePerformIO $  do +                    n <- peek n_capabilities+                    return (fromIntegral n)++foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt++childHandler :: SomeException -> IO ()+childHandler err = catchException (real_handler err) childHandler++real_handler :: SomeException -> IO ()+real_handler se@(SomeException ex) =+  -- ignore thread GC and killThread exceptions:+  case cast ex of+  Just BlockedOnDeadMVar                -> return ()+  _ -> case cast ex of+       Just BlockedIndefinitely         -> return ()+       _ -> case cast ex of+            Just ThreadKilled           -> return ()+            _ -> case cast ex of+                 -- report all others:+                 Just StackOverflow     -> reportStackOverflow+                 _                      -> reportError se++{- | 'killThread' terminates the given thread (GHC only).+Any work already done by the thread isn\'t+lost: the computation is suspended until required by another thread.+The memory used by the thread will be garbage collected if it isn\'t+referenced from anywhere.  The 'killThread' function is defined in+terms of 'throwTo':++> killThread tid = throwTo tid ThreadKilled++Killthread is a no-op if the target thread has already completed.+-}+killThread :: ThreadId -> IO ()+killThread tid = throwTo tid ThreadKilled++{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).++'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.  This is a useful property to know+when dealing with race conditions: eg. 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.++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 'block' or not.++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 8 of the paper.+Like any blocking operation, 'throwTo' is therefore interruptible (see Section 4.3 of+the paper).++There is currently no guarantee that the exception delivered by 'throwTo' will be+delivered at the first possible opportunity.  In particular, if a thread may +unblock and then re-block exceptions (using 'unblock' and 'block') without receiving+a pending 'throwTo'.  This is arguably undesirable behaviour.++ -}+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 if+you built a RTS with debugging support. 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).++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 = IO $ \ s ->+   let ps  = packCString# str+       adr = byteArrayContents# ps in+     case (labelThread# t adr s) of s1 -> (# s1, () #)++--      Nota Bene: 'pseq' used to be 'seq'+--                 but 'seq' is now defined in PrelGHC+--+-- "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 }+++data BlockReason+  = BlockedOnMVar+        -- ^blocked on on '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'.+  deriving (Eq,Ord,Show)++-- | 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,Ord,Show)++threadStatus :: ThreadId -> IO ThreadStatus+threadStatus (ThreadId t) = IO $ \s ->+   case threadStatus# t s of+     (# s', stat #) -> (# s', mk_stat (I# stat) #)+   where+        -- NB. keep these in sync with includes/Constants.h+     mk_stat 0  = ThreadRunning+     mk_stat 1  = ThreadBlocked BlockedOnMVar+     mk_stat 2  = ThreadBlocked BlockedOnBlackHole+     mk_stat 3  = ThreadBlocked BlockedOnException+     mk_stat 7  = ThreadBlocked BlockedOnSTM+     mk_stat 11 = ThreadBlocked BlockedOnForeignCall+     mk_stat 12 = ThreadBlocked BlockedOnForeignCall+     mk_stat 16 = ThreadFinished+     mk_stat 17 = ThreadDied+     mk_stat _  = ThreadBlocked BlockedOnOther+\end{code}+++%************************************************************************+%*                                                                      *+\subsection[stm]{Transactional heap operations}+%*                                                                      *+%************************************************************************++TVars are shared memory locations which support atomic memory+transactions.++\begin{code}+-- |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++INSTANCE_TYPEABLE1(STM,stmTc,"STM")++instance  Functor STM where+   fmap f x = x >>= (return . f)++instance  Monad STM  where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    m >> k      = thenSTM m k+    return x    = returnSTM x+    m >>= k     = bindSTM m k++bindSTM :: STM a -> (a -> STM b) -> STM b+bindSTM (STM m) k = STM ( \s ->+  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 #))++-- | 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.+--+-- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. +-- Any attempt to do so will result in a runtime error.  (Reason: allowing+-- this would effectively allow a transaction inside a transaction, depending+-- on exactly when the thunk is evaluated.)+--+-- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',+-- and which allows top-level TVars to be allocated.++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 TVars which mean that it should not continue (e.g. the TVars+-- represent a shared buffer that is now empty).  The implementation may+-- block the thread until one of the TVars that it has read from has been+-- udpated. (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++-- |Exception handling within STM actions.+catchSTM :: STM a -> (SomeException -> STM a) -> STM a+catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s++-- | Low-level primitive on which always and alwaysSucceeds are built.+-- checkInv differs form these in that (i) the invariant is not +-- checked when checkInv is called, only at the end of this and+-- subsequent transcations, (ii) the invariant failure is indicated+-- by raising an exception.+checkInv :: STM a -> STM ()+checkInv (STM m) = STM (\s -> (check# m) s)++-- | alwaysSucceeds adds a new invariant that must be true when passed+-- to alwaysSucceeds, at the end of the current transaction, and at+-- the end of every subsequent transaction.  If it fails at any+-- of those points then the transaction violating it is aborted+-- and the exception raised by the invariant is propagated.+alwaysSucceeds :: STM a -> STM ()+alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () ) +                      checkInv i++-- | always is a variant of alwaysSucceeds in which the invariant is+-- expressed as an STM Bool action that must return True.  Returning+-- False or raising an exception are both treated as invariant failures.+always :: STM Bool -> STM ()+always i = alwaysSucceeds ( do v <- i+                               if (v) then return () else ( error "Transacional invariant violation" ) )++-- |Shared memory locations that support atomic memory transactions.+data TVar a = TVar (TVar# RealWorld a)++INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")++instance Eq (TVar a) where+        (TVar tvar1#) == (TVar tvar2#) = 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+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#, () #)+  +\end{code}++%************************************************************************+%*                                                                      *+\subsection[mvars]{M-Structures}+%*                                                                      *+%************************************************************************++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.++\begin{code}+--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#++-- |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 #)++-- |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#, not (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) finalizer = +  IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }++withMVar :: MVar a -> (a -> IO b) -> IO b+withMVar m io = +  block $ do+    a <- takeMVar m+    b <- catchAny (unblock (io a))+            (\e -> do putMVar m a; throw e)+    putMVar m a+    return b+\end{code}+++%************************************************************************+%*                                                                      *+\subsection{Thread waiting}+%*                                                                      *+%************************************************************************++\begin{code}+#ifdef mingw32_HOST_OS++-- 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 (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)+  +asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)+asyncWriteBA fd isSock len off bufB = +  asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)++#endif++-- -----------------------------------------------------------------------------+-- Thread IO API++-- | Block the current thread until data is available to read on the+-- given file descriptor (GHC only).+threadWaitRead :: Fd -> IO ()+threadWaitRead fd+#ifndef mingw32_HOST_OS+  | threaded  = waitForReadEvent 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).+threadWaitWrite :: Fd -> IO ()+threadWaitWrite fd+#ifndef mingw32_HOST_OS+  | threaded  = waitForWriteEvent fd+#endif+  | otherwise = IO $ \s -> +        case fromIntegral fd of { I# fd# ->+        case waitWrite# fd# s of { s' -> (# s', () #)+        }}++-- | 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 fromIntegral 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 = error "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 <- getUSecOfDay+    return $ now + (fromIntegral usecs)+++-- ----------------------------------------------------------------------------+-- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay++-- In the threaded RTS, we employ a single IO Manager thread to wait+-- for all outstanding IO requests (threadWaitRead,threadWaitWrite)+-- and delays (threadDelay).  +--+-- We can do this because in the threaded RTS the IO Manager can make+-- a non-blocking call to select(), so we don't have to do select() in+-- the scheduler as we have to in the non-threaded RTS.  We get performance+-- benefits from doing it this way, because we only have to restart the select()+-- when a new request arrives, rather than doing one select() each time+-- around the scheduler loop.  Furthermore, the scheduler can be simplified+-- by not having to check for completed IO requests.++-- Issues, possible problems:+--+--      - we might want bound threads to just do the blocking+--        operation rather than communicating with the IO manager+--        thread.  This would prevent simgle-threaded programs which do+--        IO from requiring multiple OS threads.  However, it would also+--        prevent bound threads waiting on IO from being killed or sent+--        exceptions.+--+--      - Apprently exec() doesn't work on Linux in a multithreaded program.+--        I couldn't repeat this.+--+--      - How do we handle signal delivery in the multithreaded RTS?+--+--      - forkProcess will kill the IO manager thread.  Let's just+--        hope we don't need to do any blocking IO between fork & exec.++#ifndef mingw32_HOST_OS+data IOReq+  = Read   {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())+  | Write  {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())+#endif++data DelayReq+  = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())+  | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)++#ifndef mingw32_HOST_OS+pendingEvents :: IORef [IOReq]+#endif+pendingDelays :: IORef [DelayReq]+        -- could use a strict list or array here+{-# NOINLINE pendingEvents #-}+{-# NOINLINE pendingDelays #-}+(pendingEvents,pendingDelays) = unsafePerformIO $ do+  startIOManagerThread+  reqs <- newIORef []+  dels <- newIORef []+  return (reqs, dels)+        -- the first time we schedule an IO request, the service thread+        -- will be created (cool, huh?)++ensureIOManagerIsRunning :: IO ()+ensureIOManagerIsRunning +  | threaded  = seq pendingEvents $ return ()+  | otherwise = return ()++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++-- XXX: move into GHC.IOBase from Data.IORef?+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s++foreign import ccall unsafe "getUSecOfDay" +  getUSecOfDay :: IO USecs++prodding :: IORef Bool+{-# NOINLINE prodding #-}+prodding = unsafePerformIO (newIORef False)++prodServiceThread :: IO ()+prodServiceThread = do+  was_set <- atomicModifyIORef prodding (\a -> (True,a))+  if (not (was_set)) then wakeupIOManager else return ()++#ifdef mingw32_HOST_OS+-- ----------------------------------------------------------------------------+-- Windows IO manager thread++startIOManagerThread :: IO ()+startIOManagerThread = do+  wakeup <- c_getIOManagerEvent+  forkIO $ service_loop wakeup []+  return ()++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 <- atomicModifyIORef pendingDelays (\a -> ([],a))+  let  delays = foldr insertDelay old_delays new_delays++  now <- getUSecOfDay+  (delays', timeout) <- getDelay now delays++  r <- c_WaitForSingleObject wakeup timeout+  case r of+    0xffffffff -> do c_maperrno; throwErrno "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+        if exit+          then return ()+          else service_cont wakeup delays'++    _other -> service_cont wakeup delays' -- probably timeout        ++service_cont :: HANDLE -> [DelayReq] -> IO ()+service_cont wakeup delays = do+  atomicModifyIORef prodding (\_ -> (False,False))+  service_loop wakeup delays++-- must agree with rts/win32/ThrIOManager.c+io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32+io_MANAGER_WAKEUP = 0xffffffff+io_MANAGER_DIE    = 0xfffffffe++data ConsoleEvent+ = ControlC+ | Break+ | Close+    -- these are sent to Services only.+ | Logoff+ | Shutdown+ deriving (Eq, Ord, Enum, Show, Read, Typeable)++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 :: Num a => a -> Maybe ConsoleEvent+toWin32ConsoleEvent ev = +   case ev of+       0 {- CTRL_C_EVENT-}        -> Just ControlC+       1 {- CTRL_BREAK_EVENT-}    -> Just Break+       2 {- CTRL_CLOSE_EVENT-}    -> Just Close+       5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff+       6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown+       _ -> Nothing++win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())+win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))++-- XXX Is this actually needed?+stick :: IORef HANDLE+{-# NOINLINE stick #-}+stick = unsafePerformIO (newIORef nullPtr)++wakeupIOManager :: IO ()+wakeupIOManager = do +  _hdl <- readIORef stick+  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)++-- 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...+type HANDLE       = Ptr ()+type DWORD        = Word32++iNFINITE :: DWORD+iNFINITE = 0xFFFFFFFF -- urgh++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 ccall unsafe "maperrno"             -- in Win32Utils.c+   c_maperrno :: IO ()++foreign import stdcall "WaitForSingleObject"+   c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD++#else+-- ----------------------------------------------------------------------------+-- Unix IO manager thread, using select()++startIOManagerThread :: IO ()+startIOManagerThread = do+        allocaArray 2 $ \fds -> do+        throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)+        rd_end <- peekElemOff fds 0+        wr_end <- peekElemOff fds 1+        writeIORef stick (fromIntegral wr_end)+        c_setIOManagerPipe wr_end+        forkIO $ do+            allocaBytes sizeofFdSet   $ \readfds -> do+            allocaBytes sizeofFdSet   $ \writefds -> do +            allocaBytes sizeofTimeVal $ \timeval -> do+            service_loop (fromIntegral rd_end) readfds writefds timeval [] []+        return ()++service_loop+   :: Fd                -- listen to this for wakeup calls+   -> Ptr CFdSet+   -> Ptr CFdSet+   -> Ptr CTimeVal+   -> [IOReq]+   -> [DelayReq]+   -> IO ()+service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do++  -- pick up new IO requests+  new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))+  let reqs = new_reqs ++ old_reqs++  -- pick up new delay requests+  new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))+  let  delays0 = foldr insertDelay old_delays new_delays++  -- build the FDSets for select()+  fdZero readfds+  fdZero writefds+  fdSet wakeup readfds+  maxfd <- buildFdSets 0 readfds writefds reqs++  -- perform the select()+  let do_select delays = do+          -- check the current time and wake up any thread in+          -- threadDelay whose timeout has expired.  Also find the+          -- timeout value for the select() call.+          now <- getUSecOfDay+          (delays', timeout) <- getDelay now ptimeval delays++          res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds +                        nullPtr timeout+          if (res == -1)+             then do+                err <- getErrno+                case err of+                  _ | err == eINTR ->  do_select delays'+                        -- EINTR: just redo the select()+                  _ | err == eBADF ->  return (True, delays)+                        -- EBADF: one of the file descriptors is closed or bad,+                        -- we don't know which one, so wake everyone up.+                  _ | otherwise    ->  throwErrno "select"+                        -- otherwise (ENOMEM or EINVAL) something has gone+                        -- wrong; report the error.+             else+                return (False,delays')++  (wakeup_all,delays') <- do_select delays0++  exit <-+    if wakeup_all then return False+      else do+        b <- fdIsSet wakeup readfds+        if b == 0 +          then return False+          else alloca $ \p -> do +                 c_read (fromIntegral wakeup) p 1; return ()+                 s <- peek p            +                 case s of+                  _ | s == io_MANAGER_WAKEUP -> return False+                  _ | s == io_MANAGER_DIE    -> return True+                  _ -> withMVar signalHandlerLock $ \_ -> do+                          handler_tbl <- peek handlers+                          sp <- peekElemOff handler_tbl (fromIntegral s)+                          io <- deRefStablePtr sp+                          forkIO io+                          return False++  if exit then return () else do++  atomicModifyIORef prodding (\_ -> (False,False))++  reqs' <- if wakeup_all then do wakeupAll reqs; return []+                         else completeRequests reqs readfds writefds []++  service_loop wakeup readfds writefds ptimeval reqs' delays'++io_MANAGER_WAKEUP, io_MANAGER_DIE :: CChar+io_MANAGER_WAKEUP = 0xff+io_MANAGER_DIE    = 0xfe++stick :: IORef Fd+{-# NOINLINE stick #-}+stick = unsafePerformIO (newIORef 0)++wakeupIOManager :: IO ()+wakeupIOManager = do+  fd <- readIORef stick+  with io_MANAGER_WAKEUP $ \pbuf -> do +    c_write (fromIntegral fd) pbuf 1; return ()++-- Lock used to protect concurrent access to signal_handlers.  Symptom of+-- this race condition is #1922, although that bug was on Windows a similar+-- bug also exists on Unix.+signalHandlerLock :: MVar ()+signalHandlerLock = unsafePerformIO (newMVar ())++foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ())))++foreign import ccall "setIOManagerPipe"+  c_setIOManagerPipe :: CInt -> IO ()++-- -----------------------------------------------------------------------------+-- IO requests++buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd+buildFdSets maxfd _       _        [] = return maxfd+buildFdSets maxfd readfds writefds (Read fd _ : reqs)+  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"+  | otherwise        =  do+        fdSet fd readfds+        buildFdSets (max maxfd fd) readfds writefds reqs+buildFdSets maxfd readfds writefds (Write fd _ : reqs)+  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"+  | otherwise        =  do+        fdSet fd writefds+        buildFdSets (max maxfd fd) readfds writefds reqs++completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]+                 -> IO [IOReq]+completeRequests [] _ _ reqs' = return reqs'+completeRequests (Read fd m : reqs) readfds writefds reqs' = do+  b <- fdIsSet fd readfds+  if b /= 0+    then do putMVar m (); completeRequests reqs readfds writefds reqs'+    else completeRequests reqs readfds writefds (Read fd m : reqs')+completeRequests (Write fd m : reqs) readfds writefds reqs' = do+  b <- fdIsSet fd writefds+  if b /= 0+    then do putMVar m (); completeRequests reqs readfds writefds reqs'+    else completeRequests reqs readfds writefds (Write fd m : reqs')++wakeupAll :: [IOReq] -> IO ()+wakeupAll [] = return ()+wakeupAll (Read  _ m : reqs) = do putMVar m (); wakeupAll reqs+wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs++waitForReadEvent :: Fd -> IO ()+waitForReadEvent fd = do+  m <- newEmptyMVar+  atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))+  prodServiceThread+  takeMVar m++waitForWriteEvent :: Fd -> IO ()+waitForWriteEvent fd = do+  m <- newEmptyMVar+  atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))+  prodServiceThread+  takeMVar m++-- -----------------------------------------------------------------------------+-- Delays++-- 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 -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)+getDelay _   _        [] = return ([],nullPtr)+getDelay now ptimeval all@(d : rest) +  = case d of+     Delay time m | now >= time -> do+        putMVar m ()+        getDelay now ptimeval rest+     DelaySTM time t | now >= time -> do+        atomically $ writeTVar t True+        getDelay now ptimeval rest+     _otherwise -> do+        setTimevalTicks ptimeval (delayTime d - now)+        return (all,ptimeval)++data CTimeVal++foreign import ccall unsafe "sizeofTimeVal"+  sizeofTimeVal :: Int++foreign import ccall unsafe "setTimevalTicks" +  setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()++{- +  On Win32 we're going to have a single Pipe, and a+  waitForSingleObject with the delay time.  For signals, we send a+  byte down the pipe just like on Unix.+-}++-- ----------------------------------------------------------------------------+-- select() interface++-- ToDo: move to System.Posix.Internals?++data CFdSet++foreign import ccall safe "select"+  c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal+           -> IO CInt++foreign import ccall unsafe "hsFD_SETSIZE"+  c_fD_SETSIZE :: CInt++fD_SETSIZE :: Fd+fD_SETSIZE = fromIntegral c_fD_SETSIZE++foreign import ccall unsafe "hsFD_ISSET"+  c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt++fdIsSet :: Fd -> Ptr CFdSet -> IO CInt+fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset++foreign import ccall unsafe "hsFD_SET"+  c_fdSet :: CInt -> Ptr CFdSet -> IO ()++fdSet :: Fd -> Ptr CFdSet -> IO ()+fdSet (Fd fd) fdset = c_fdSet fd fdset++foreign import ccall unsafe "hsFD_ZERO"+  fdZero :: Ptr CFdSet -> IO ()++foreign import ccall unsafe "sizeof_fd_set"+  sizeofFdSet :: Int++#endif++reportStackOverflow :: IO a+reportStackOverflow = do callStackOverflowHook; return undefined++reportError :: SomeException -> IO a+reportError ex = do+   handler <- getUncaughtExceptionHandler+   handler ex+   return undefined++-- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove+-- the unsafe below.+foreign import ccall unsafe "stackOverflow"+        callStackOverflowHook :: 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?"+               _ -> case cast ex of+                    Just (ErrorCall s) -> s+                    _                  -> 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+\end{code}
GHC/ConsoleHandler.hs view
@@ -1,2 +1,152 @@-module GHC.ConsoleHandler ({- empty: module X___ -}) where-import "base" GHC.ConsoleHandler as X___ ()+{-# OPTIONS_GHC -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) && !defined(__HADDOCK__)+        where+import Prelude -- necessary to get dependencies right+#else /* whole file */+        ( Handler(..)+        , installHandler+        , ConsoleEvent(..)+        , flushConsole+        ) where++{-+#include "Signals.h"+-}++import Prelude -- necessary to get dependencies right++import Foreign+import Foreign.C+import GHC.IOBase+import GHC.Conc+import GHC.Handle+import Control.Exception (onException)++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)+          _           -> error "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)))+     _           -> error "installHandler: Bad non-threaded rc value"+  where+   fromConsoleEvent ev =+     case ev of+       ControlC -> 0 {- CTRL_C_EVENT-}+       Break    -> 1 {- CTRL_BREAK_EVENT-}+       Close    -> 2 {- CTRL_CLOSE_EVENT-}+       Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}+       Shutdown -> 6 {- 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 = error "win32ConsoleHandler"++foreign import ccall "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 ()+++flushConsole :: Handle -> IO ()+flushConsole h =+  wantReadableHandle "flushConsole" h $ \ h_ ->+     throwErrnoIfMinus1Retry_ "flushConsole"+      (flush_console_fd (fromIntegral (haFD h_)))++foreign import ccall unsafe "consUtils.h flush_input_console__"+        flush_console_fd :: CInt -> IO CInt++-- XXX Copied from Control.Concurrent.MVar+modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b+modifyMVar m io =+  block $ do+    a      <- takeMVar m+    (a',b) <- unblock (io a) `onException` putMVar m a+    putMVar m a'+    return b+#endif /* mingw32_HOST_OS */
GHC/Desugar.hs view
@@ -1,2 +1,30 @@-module GHC.Desugar (module X___) where-import "base" GHC.Desugar as X___+-----------------------------------------------------------------------------+-- |+-- 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+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Desugar ((>>>)) where++import Control.Arrow    (Arrow(..))+import Control.Category ((.))+import Prelude hiding ((.))++-- A version of Control.Category.>>> overloaded on Arrow+#ifndef __HADDOCK__+(>>>) :: forall arr. Arrow arr => forall a b c. arr a b -> arr b c -> arr a c+#endif+-- 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
− GHC/Dotnet.hs 
@@ -1,1 +0,0 @@-module GHC.Dotnet () where
− GHC/Enum.hs 
@@ -1,2 +0,0 @@-module GHC.Enum (module X___) where-import "base" GHC.Enum as X___
+ GHC/Enum.lhs view
@@ -0,0 +1,586 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Enum(+        Bounded(..), Enum(..),+        boundedEnumFrom, boundedEnumFromThen,++        -- Instances for Bounded and Enum: (), Char, Int++   ) where++import GHC.Base+import Data.Tuple       ()              -- for dependencies+default ()              -- Double isn't available yet+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Class declarations}+%*                                                      *+%*********************************************************++\begin{code}+-- | 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..]@.+    enumFrom            :: a -> [a]+    -- | Used in Haskell's translation of @[n,n'..]@.+    enumFromThen        :: a -> a -> [a]+    -- | Used in Haskell's translation of @[n..m]@.+    enumFromTo          :: a -> a -> [a]+    -- | Used in Haskell's translation of @[n,n'..m]@.+    enumFromThenTo      :: a -> a -> a -> [a]++    succ                   = toEnum . (`plusInt` oneInt)  . fromEnum+    pred                   = toEnum . (`minusInt` oneInt) . fromEnum+    enumFrom x             = map toEnum [fromEnum x ..]+    enumFromThen x y       = map toEnum [fromEnum x, fromEnum y ..]+    enumFromTo x y         = map toEnum [fromEnum x .. fromEnum y]+    enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]++-- Default methods for bounded enumerations+boundedEnumFrom :: (Enum a, Bounded a) => a -> [a]+boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)]++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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Tuples}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded () where+    minBound = ()+    maxBound = ()++instance Enum () where+    succ _      = error "Prelude.Enum.().succ: bad argument"+    pred _      = error "Prelude.Enum.().pred: bad argument"++    toEnum x | x == zeroInt = ()+             | otherwise    = error "Prelude.Enum.().toEnum: bad argument"++    fromEnum () = zeroInt+    enumFrom ()         = [()]+    enumFromThen () ()  = let many = ():many in many+    enumFromTo () ()    = [()]+    enumFromThenTo () () () = let many = ():many in many+\end{code}++\begin{code}+-- Report requires instances up to 15+instance (Bounded a, Bounded b) => Bounded (a,b) where+   minBound = (minBound, minBound)+   maxBound = (maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c) => Bounded (a,b,c) where+   minBound = (minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a,b,c,d) where+   minBound = (minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e) => Bounded (a,b,c,d,e) where+   minBound = (minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f)+        => Bounded (a,b,c,d,e,f) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g)+        => Bounded (a,b,c,d,e,f,g) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)++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) where+   minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,+               minBound, minBound, minBound, minBound, minBound, minBound, minBound)+   maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,+               maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Bool@}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded Bool where+  minBound = False+  maxBound = True++instance Enum Bool where+  succ False = True+  succ True  = error "Prelude.Enum.Bool.succ: bad argument"++  pred True  = False+  pred False  = error "Prelude.Enum.Bool.pred: bad argument"++  toEnum n | n == zeroInt = False+           | n == oneInt  = True+           | otherwise    = error "Prelude.Enum.Bool.toEnum: bad argument"++  fromEnum False = zeroInt+  fromEnum True  = oneInt++  -- Use defaults for the rest+  enumFrom     = boundedEnumFrom+  enumFromThen = boundedEnumFromThen+\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Ordering@}+%*                                                      *+%*********************************************************++\begin{code}+instance Bounded Ordering where+  minBound = LT+  maxBound = GT++instance Enum Ordering where+  succ LT = EQ+  succ EQ = GT+  succ GT = error "Prelude.Enum.Ordering.succ: bad argument"++  pred GT = EQ+  pred EQ = LT+  pred LT = error "Prelude.Enum.Ordering.pred: bad argument"++  toEnum n | n == zeroInt = LT+           | n == oneInt  = EQ+           | n == twoInt  = GT+  toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument"++  fromEnum LT = zeroInt+  fromEnum EQ = oneInt+  fromEnum GT = twoInt++  -- Use defaults for the rest+  enumFrom     = boundedEnumFrom+  enumFromThen = boundedEnumFromThen+\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Char@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Bounded Char  where+    minBound =  '\0'+    maxBound =  '\x10FFFF'++instance  Enum Char  where+    succ (C# c#)+       | not (ord# c# ==# 0x10FFFF#) = C# (chr# (ord# c# +# 1#))+       | otherwise              = error ("Prelude.Enum.Char.succ: bad argument")+    pred (C# c#)+       | not (ord# c# ==# 0#)   = C# (chr# (ord# c# -# 1#))+       | otherwise              = error ("Prelude.Enum.Char.pred: bad argument")++    toEnum   = chr+    fromEnum = ord++    {-# INLINE enumFrom #-}+    enumFrom (C# x) = eftChar (ord# x) 0x10FFFF#+        -- Blarg: technically I guess enumFrom isn't strict!++    {-# INLINE enumFromTo #-}+    enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y)+    +    {-# INLINE enumFromThen #-}+    enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2)+    +    {-# INLINE enumFromThenTo #-}+    enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y)++{-# 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 #-}+eftCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a+eftCharFB c n x0 y = go x0+                 where+                    go x | x ># y    = n+                         | otherwise = C# (chr# x) `c` go (x +# 1#)++eftChar :: Int# -> Int# -> String+eftChar x y | x ># y    = []+            | otherwise = C# (chr# x) : eftChar (x +# 1#) y+++-- For enumFromThenTo we give up on inlining+{-# NOINLINE [0] efdCharFB #-}+efdCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> a+efdCharFB c n x1 x2+  | 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++efdChar :: Int# -> Int# -> String+efdChar x1 x2+  | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF#+  | otherwise    = go_dn_char_list x1 delta 0#+  where+    delta = x2 -# x1++{-# NOINLINE [0] efdtCharFB #-}+efdtCharFB :: (Char -> a -> a) -> a -> Int# -> Int# -> Int# -> a+efdtCharFB c n x1 x2 lim+  | 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++efdtChar :: Int# -> Int# -> Int# -> String+efdtChar x1 x2 lim+  | 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 | 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 | 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 | 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 | x <# lim  = []+            | otherwise = C# (chr# x) : go_dn (x +# delta)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @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++Also NB that the Num class isn't available in this module.+        +\begin{code}+instance  Bounded Int where+    minBound =  minInt+    maxBound =  maxInt++instance  Enum Int  where+    succ x  +       | x == maxBound  = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound"+       | otherwise      = x `plusInt` oneInt+    pred x+       | x == minBound  = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound"+       | otherwise      = x `minusInt` oneInt++    toEnum   x = x+    fromEnum x = x++    {-# INLINE enumFrom #-}+    enumFrom (I# x) = eftInt x maxInt#+        where I# maxInt# = maxInt+        -- Blarg: technically I guess enumFrom isn't strict!++    {-# INLINE enumFromTo #-}+    enumFromTo (I# x) (I# y) = eftInt x y++    {-# INLINE enumFromThen #-}+    enumFromThen (I# x1) (I# x2) = efdInt x1 x2++    {-# 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+ #-}++eftInt :: Int# -> Int# -> [Int]+-- [x1..x2]+eftInt x0 y | x0 ># y    = []+            | otherwise = go x0+               where+                 go x = I# x : if x ==# y then [] else go (x +# 1#)++{-# INLINE [0] eftIntFB #-}+eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+eftIntFB c n x0 y | x0 ># y    = n        +                  | otherwise = go x0+                 where+                   go x = I# x `c` if 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.++{-# 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 + | x2 >=# x1 = case maxInt of I# y -> efdtIntUp x1 x2 y+ | otherwise = case minInt of I# y -> efdtIntDn x1 x2 y++efdtInt :: Int# -> Int# -> Int# -> [Int]+-- [x1,x2..y]+efdtInt x1 x2 y+ | x2 >=# x1 = efdtIntUp x1 x2 y+ | otherwise = efdtIntDn x1 x2 y++{-# INLINE [0] efdtIntFB #-}+efdtIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r+efdtIntFB c n x1 x2 y+ | 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!+ | y <# x2   = if 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 | x ># y'  = [I# x]+                           | otherwise = I# x : go_up (x +# delta)+               in I# x1 : go_up x2++-- Requires x2 >= x1+efdtIntUpFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r+efdtIntUpFB c n x1 x2 y    -- Be careful about overflow!+ | y <# x2   = if 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 | 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!+ | y ># x2   = if 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 | x <# y'  = [I# x]+                           | otherwise = I# x : go_dn (x +# delta)+   in I# x1 : go_dn x2++-- Requires x2 <= x1+efdtIntDnFB :: (Int -> r -> r) -> r -> Int# -> Int# -> Int# -> r+efdtIntDnFB c n x1 x2 y    -- Be careful about underflow!+ | y ># x2 = if 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 | x <# y'   = I# x `c` n+                           | otherwise = I# x `c` go_dn (x +# delta)+               in I# x1 `c` go_dn x2+\end{code}+
GHC/Environment.hs view
@@ -1,2 +1,20 @@-module GHC.Environment (module X___) where-import "base" GHC.Environment as X___++module GHC.Environment (getFullArgs) where++import Prelude+import Foreign+import Foreign.C+import Control.Monad++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+   peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString++foreign import ccall unsafe "getFullProgArgv"+    getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()+
− GHC/Err.hs 
@@ -1,2 +0,0 @@-module GHC.Err (module X___) where-import "base" GHC.Err as X___
+ GHC/Err.lhs view
@@ -0,0 +1,89 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Err+       (+         absentErr                 -- :: a+       , divZeroError              -- :: a+       , overflowError             -- :: a++       , error                     -- :: String -> a++       , undefined                 -- :: a+       ) where++#ifndef __HADDOCK__+import GHC.Types+import GHC.Exception+#endif+\end{code}++%*********************************************************+%*                                                      *+\subsection{Error-ish functions}+%*                                                      *+%*********************************************************++\begin{code}+-- | 'error' stops execution and displays an error message.+error :: [Char] -> a+error s = throw (ErrorCall s)++-- | A special case of 'error'.+-- It is expected that compilers will recognize this and insert error+-- messages which are more appropriate to the context in which 'undefined'+-- appears. ++undefined :: a+undefined =  error "Prelude.undefined"+\end{code}++%*********************************************************+%*                                                       *+\subsection{Compiler generated errors + local utils}+%*                                                       *+%*********************************************************++Used for compiler-generated error message;+encoding saves bytes of string junk.++\begin{code}+absentErr :: a++absentErr = error "Oops! The program has entered an `absent' argument!\n"+\end{code}++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.++\begin{code}+{-# NOINLINE divZeroError #-}+divZeroError :: a+divZeroError = throw DivideByZero++{-# NOINLINE overflowError #-}+overflowError :: a+overflowError = throw Overflow+\end{code}+
− GHC/Exception.hs 
@@ -1,2 +0,0 @@-module GHC.Exception (module X___) where-import "base" GHC.Exception as X___
+ GHC/Exception.lhs view
@@ -0,0 +1,94 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.Exception where++import Data.Maybe+import {-# SOURCE #-} Data.Typeable+import GHC.Base+import GHC.Show+\end{code}++%*********************************************************+%*                                                      *+\subsection{Exceptions}+%*                                                      *+%*********************************************************++\begin{code}+data SomeException = forall e . Exception e => SomeException e+    deriving Typeable++instance Show SomeException where+    showsPrec p (SomeException e) = showsPrec p e++class (Typeable e, Show e) => Exception e where+    toException   :: e -> SomeException+    fromException :: SomeException -> Maybe e++    toException = SomeException+    fromException (SomeException e) = cast e++instance Exception SomeException where+    toException se = se+    fromException = Just+\end{code}++%*********************************************************+%*                                                      *+\subsection{Primitive throw}+%*                                                      *+%*********************************************************++\begin{code}+-- | Throw an exception.  Exceptions may be thrown from purely+-- functional code, but may only be caught within the 'IO' monad.+throw :: Exception e => e -> a+throw e = raise# (toException e)+\end{code}++\begin{code}+data ErrorCall = ErrorCall String+    deriving Typeable++instance Exception ErrorCall++instance Show ErrorCall where+    showsPrec _ (ErrorCall err) = showString err++-----++-- |The type of arithmetic exceptions+data ArithException+  = Overflow+  | Underflow+  | LossOfPrecision+  | DivideByZero+  | Denormal+  deriving (Eq, Ord, Typeable)++instance Exception ArithException++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"++\end{code}
GHC/Exts.hs view
@@ -1,2 +1,99 @@-module GHC.Exts (module X___) where-import "base" GHC.Exts as X___+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++module GHC.Exts+       (+        -- * Representations of some basic types+        Int(..),Word(..),Float(..),Double(..),+        Char(..),+        Ptr(..), FunPtr(..),++        -- * The maximum tuple size+        maxTupleSize,++        -- * Primitive operations+        module GHC.Prim,+        shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,+        uncheckedShiftL64#, uncheckedShiftRL64#,+        uncheckedIShiftL64#, uncheckedIShiftRA64#,++        -- * Fusion+        build, augment,++        -- * Overloaded string literals+        IsString(..),++        -- * Debugging+        breakpoint, breakpointCond,++        -- * Ids with special behaviour+        lazy, inline,++        -- * Transform comprehensions+        Down(..), groupWith, sortWith, the++       ) where++import Prelude++import GHC.Prim+import GHC.Base+import GHC.Word+import GHC.Int+import GHC.Float+import GHC.Ptr+import Data.String+import Data.List++-- XXX This should really be in Data.Tuple, where the definitions are+maxTupleSize :: Int+maxTupleSize = 62++-- | 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@+newtype Down a = Down a deriving (Eq)++instance Ord a => Ord (Down a) where+    compare (Down x) (Down y) = y `compare` x++-- | '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     = error "GHC.Exts.the: non-identical elements"+the []            = error "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 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))++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+
− GHC/Float.hs 
@@ -1,2 +0,0 @@-module GHC.Float (module X___) where-import "base" GHC.Float as X___
+ GHC/Float.lhs view
@@ -0,0 +1,992 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Float+-- 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 'Float' and 'Double', and the classes 'Floating' and 'RealFloat'.+--+-----------------------------------------------------------------------------++#include "ieee-flpt.h"++-- #hide+module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# )+    where++import Data.Maybe++import GHC.Base+import GHC.List+import GHC.Enum+import GHC.Show+import GHC.Num+import GHC.Real+import GHC.Arr++infixr 8  **+\end{code}++%*********************************************************+%*                                                      *+\subsection{Standard numeric classes}+%*                                                      *+%*********************************************************++\begin{code}+-- | Trigonometric and hyperbolic functions and related functions.+--+-- Minimal complete definition:+--      'pi', 'exp', 'log', 'sin', 'cos', 'sinh', 'cosh',+--      'asin', 'acos', 'atan', 'asinh', 'acosh' and 'atanh'+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++    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++-- | Efficient, machine-independent access to the components of a+-- floating-point number.+--+-- Minimal complete definition:+--      all except 'exponent', 'significand', 'scaleFloat' and 'atan2'+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) <= m < b^d@, where @d@ is the value+    -- of @'floatDigits' x@.  In particular, @'decodeFloat' 0 = (0,0)@.+    decodeFloat         :: a -> (Integer,Int)+    -- | 'encodeFloat' performs the inverse of 'decodeFloat'+    encodeFloat         :: Integer -> Int -> a+    -- | the second component of 'decodeFloat'.+    exponent            :: a -> Int+    -- | the first component of 'decodeFloat', scaled to lie in the open+    -- interval (@-1@,@1@)+    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 k x      =  encodeFloat m (n+k)+                           where (m,n) = decodeFloat 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 +)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Type @Float@}+%*                                                      *+%*********************************************************++\begin{code}+instance Eq Float where+    (F# x) == (F# y) = x `eqFloat#` y++instance Ord Float where+    (F# x) `compare` (F# y) | x `ltFloat#` y = LT+                            | x `eqFloat#` y = EQ+                            | otherwise      = GT++    (F# x) <  (F# y) = x `ltFloat#`  y+    (F# x) <= (F# y) = x `leFloat#`  y+    (F# x) >= (F# y) = x `geFloat#`  y+    (F# x) >  (F# y) = x `gtFloat#`  y++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 | x >= 0.0    =  x+          | otherwise   =  negateFloat x+    signum x | x == 0.0  = 0+             | x > 0.0   = 1+             | otherwise = negate 1++    {-# INLINE fromInteger #-}+    fromInteger i = F# (floatFromInteger i)++instance  Real Float  where+    toRational x        =  (m%1)*(b%1)^^n+                           where (m,n) = decodeFloat x+                                 b     = floatRadix  x++instance  Fractional Float  where+    (/) x y             =  divideFloat x y+    fromRational x      =  fromRat x+    recip x             =  1.0 / x++{-# RULES "truncate/Float->Int" truncate = float2Int #-}+instance  RealFrac Float  where++    {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}+    {-# SPECIALIZE round    :: Float -> Int #-}++    {-# SPECIALIZE properFraction :: Float  -> (Integer, Float) #-}+    {-# SPECIALIZE round    :: Float -> Integer #-}++        -- ceiling, floor, and truncate are all small+    {-# INLINE ceiling #-}+    {-# INLINE floor #-}+    {-# INLINE truncate #-}++    properFraction x+      = case (decodeFloat x)      of { (m,n) ->+        let  b = floatRadix x     in+        if n >= 0 then+            (fromInteger m * fromInteger b ^ n, 0.0)+        else+            case (quotRem m (b^(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++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 = log (x + sqrt (1.0+x*x))+    acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))+    atanh x = log ((x+1.0) / sqrt (1.0-x*x))++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 decodeFloatInteger f# of+                          (# i, e #) -> (i, I# e)++    encodeFloat i (I# e) = F# (encodeFloatInteger 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 k x      = case decodeFloat x of+                            (m,n) -> encodeFloat m (n+k)+    isNaN x          = 0 /= isFloatNaN x+    isInfinite x     = 0 /= isFloatInfinite x+    isDenormalized x = 0 /= isFloatDenormalized x+    isNegativeZero x = 0 /= isFloatNegativeZero x+    isIEEE _         = True++instance  Show Float  where+    showsPrec   x = showSignedFloat showFloat x+    showList = showList__ (showsPrec 0) +\end{code}++%*********************************************************+%*                                                      *+\subsection{Type @Double@}+%*                                                      *+%*********************************************************++\begin{code}+instance Eq Double where+    (D# x) == (D# y) = x ==## y++instance Ord Double where+    (D# x) `compare` (D# y) | x <## y   = LT+                            | x ==## y  = EQ+                            | otherwise = GT++    (D# x) <  (D# y) = x <##  y+    (D# x) <= (D# y) = x <=## y+    (D# x) >= (D# y) = x >=## y+    (D# x) >  (D# y) = x >##  y++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 | x >= 0.0    =  x+          | otherwise   =  negateDouble x+    signum x | x == 0.0  = 0+             | x > 0.0   = 1+             | otherwise = negate 1++    {-# INLINE fromInteger #-}+    fromInteger i = D# (doubleFromInteger i)+++instance  Real Double  where+    toRational x        =  (m%1)*(b%1)^^n+                           where (m,n) = decodeFloat x+                                 b     = floatRadix  x++instance  Fractional Double  where+    (/) x y             =  divideDouble x y+    fromRational x      =  fromRat x+    recip x             =  1.0 / x++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 = log (x + sqrt (1.0+x*x))+    acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))+    atanh x = log ((x+1.0) / sqrt (1.0-x*x))++{-# RULES "truncate/Double->Int" truncate = double2Int #-}+instance  RealFrac Double  where++    {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}+    {-# SPECIALIZE round    :: Double -> Int #-}++    {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}+    {-# SPECIALIZE round    :: Double -> Integer #-}++        -- ceiling, floor, and truncate are all small+    {-# INLINE ceiling #-}+    {-# INLINE floor #-}+    {-# INLINE truncate #-}++    properFraction x+      = case (decodeFloat x)      of { (m,n) ->+        let  b = floatRadix x     in+        if n >= 0 then+            (fromInteger m * fromInteger b ^ n, 0.0)+        else+            case (quotRem m (b^(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++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 decodeDoubleInteger x#   of+          (# i, j #) -> (i, I# j)++    encodeFloat i (I# j) = D# (encodeDoubleInteger 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 k x      = case decodeFloat x of+                            (m,n) -> encodeFloat m (n+k)++    isNaN x             = 0 /= isDoubleNaN x+    isInfinite x        = 0 /= isDoubleInfinite x+    isDenormalized x    = 0 /= isDoubleDenormalized x+    isNegativeZero x    = 0 /= isDoubleNegativeZero x+    isIEEE _            = True++instance  Show Double  where+    showsPrec   x = showSignedFloat showFloat x+    showList = showList__ (showsPrec 0) +\end{code}++%*********************************************************+%*                                                      *+\subsection{@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.)++\begin{code}+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++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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Printing floating point}+%*                                                      *+%*********************************************************+++\begin{code}+-- | 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++formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String+formatRealFloat fmt decs 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'+          []      -> error "formatRealFloat/doFmt/FFExponent: []"+       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 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' then "" else '.':ds')+++roundTo :: Int -> Int -> [Int] -> (Int,[Int])+roundTo base d is =+  case f d is of+    x@(0,_) -> x+    (1,xs)  -> (1, 1:xs)+    _       -> error "roundTo: bad Value"+ where+  b2 = base `div` 2++  f n []     = (0, replicate n 0)+  f 0 (x:_)  = (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) 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 `div` (b^n), e0+n) else (f0, e0)+  (r, s, mUp, mDn) =+   if e >= 0 then+    let be = b^ e in+    if f == b^(p-1) then+      (f*be*b*2, 2*b, be*b, b)+    else+      (f*be*2, 2, be, be)+   else+    if e > minExp && f == b^(p-1) then+      (f*b*2, b^(-e+1)*2, b, 1)+    else+      (f*2, b^(-e)*2, 1, 1)+  k :: Int+  k =+   let +    k0 :: Int+    k0 =+     if b == 2 && base == 10 then+        -- logBase 10 2 is slightly bigger than 3/10 so+        -- the following will err on the low side.  Ignoring+        -- the fraction will make it err even more.+        -- Haskell promises that p-1 <= logBase b f < p.+        (p - 1 + e0) * 3 `div` 10+     else+        ceiling ((log (fromInteger (f+1)) ++                 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) `divMod` 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)++\end{code}+++%*********************************************************+%*                                                      *+\subsection{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)++\begin{code}+-- | Converts a 'Rational' value into any type in class 'RealFloat'.+{-# SPECIALISE fromRat :: Rational -> Double,+                          Rational -> Float #-}+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+        xMin   = toRational (expt b (p-1))+        xMax   = toRational (expt b p)+        p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp+        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1+        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)+        r = encodeFloat (round x') p'++-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.+scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)+scaleRat b minExp xMin xMax p x + | p <= minExp = (x, p)+ | x >= xMax   = scaleRat b minExp xMin xMax (p+1) (x/b)+ | x < xMin    = scaleRat b minExp xMin xMax (p-1) (x*b)+ | otherwise   = (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+        base^n++expts :: Array Int Integer+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]++-- Compute the (floor of the) log of i in base b.+-- Simplest way would be just divide i by b until it's smaller then b, but that would+-- be very slow!  We are just slightly more clever.+integerLogBase :: Integer -> Integer -> Int+integerLogBase b i+   | i < b     = 0+   | otherwise = doDiv (i `div` (b^l)) l+       where+        -- Try squaring the base first to cut down the number of divisions.+         l = 2 * integerLogBase (b*b) i++         doDiv :: Integer -> Int -> Int+         doDiv x y+            | x < b     = y+            | otherwise = doDiv (x `div` b) (y+1)++\end{code}+++%*********************************************************+%*                                                      *+\subsection{Floating point numeric primops}+%*                                                      *+%*********************************************************++Definitions of the boxed PrimOps; these will be+used in the case of partial applications, etc.++\begin{code}+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, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool+gtFloat     (F# x) (F# y) = gtFloat# x y+geFloat     (F# x) (F# y) = geFloat# x y+eqFloat     (F# x) (F# y) = eqFloat# x y+neFloat     (F# x) (F# y) = neFloat# x y+ltFloat     (F# x) (F# y) = ltFloat# x y+leFloat     (F# x) (F# y) = leFloat# x y++float2Int :: Float -> Int+float2Int   (F# x) = I# (float2Int# x)++int2Float :: Int -> Float+int2Float   (I# x) = F# (int2Float# x)++expFloat, logFloat, sqrtFloat :: Float -> Float+sinFloat, cosFloat, tanFloat  :: Float -> Float+asinFloat, acosFloat, atanFloat  :: Float -> Float+sinhFloat, coshFloat, tanhFloat  :: Float -> Float+expFloat    (F# x) = F# (expFloat# x)+logFloat    (F# x) = F# (logFloat# x)+sqrtFloat   (F# x) = F# (sqrtFloat# 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)++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, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool+gtDouble    (D# x) (D# y) = x >## y+geDouble    (D# x) (D# y) = x >=## y+eqDouble    (D# x) (D# y) = x ==## y+neDouble    (D# x) (D# y) = x /=## y+ltDouble    (D# x) (D# y) = x <## y+leDouble    (D# x) (D# y) = x <=## y++double2Int :: Double -> Int+double2Int   (D# x) = I# (double2Int#   x)++int2Double :: Int -> Double+int2Double   (I# x) = D# (int2Double#   x)++double2Float :: Double -> Float+double2Float (D# x) = F# (double2Float# x)++float2Double :: Float -> Double+float2Double (F# x) = D# (float2Double# x)++expDouble, logDouble, sqrtDouble :: Double -> Double+sinDouble, cosDouble, tanDouble  :: Double -> Double+asinDouble, acosDouble, atanDouble  :: Double -> Double+sinhDouble, coshDouble, tanhDouble  :: Double -> Double+expDouble    (D# x) = D# (expDouble# x)+logDouble    (D# x) = D# (logDouble# x)+sqrtDouble   (D# x) = D# (sqrtDouble# 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)++powerDouble :: Double -> Double -> Double+powerDouble  (D# x) (D# y) = D# (x **## y)+\end{code}++\begin{code}+foreign import ccall unsafe "__encodeFloat"+        encodeFloat# :: Int# -> ByteArray# -> Int -> Float+foreign import ccall unsafe "__int_encodeFloat"+        int_encodeFloat# :: Int# -> Int -> Float+++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 "__encodeDouble"+        encodeDouble# :: Int# -> ByteArray# -> Int -> Double++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+\end{code}++%*********************************************************+%*                                                      *+\subsection{Coercion rules}+%*                                                      *+%*********************************************************++\begin{code}+{-# RULES+"fromIntegral/Int->Float"   fromIntegral = int2Float+"fromIntegral/Int->Double"  fromIntegral = int2Double+"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+    #-}+\end{code}++Note [realToFrac int-to-float]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don found that the RULES for realToFrac/Int->Double and simliarly+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 Trac #2251, and the patch message +"Add RULES for realToFrac from Int".++%*********************************************************+%*                                                      *+\subsection{Utils}+%*                                                      *+%*********************************************************++\begin{code}+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+\end{code}
GHC/ForeignPtr.hs view
@@ -1,2 +1,324 @@-module GHC.ForeignPtr (module X___) where-import "base" GHC.ForeignPtr as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+-- +-----------------------------------------------------------------------------++-- #hide+module GHC.ForeignPtr+  (+        ForeignPtr(..),+        FinalizerPtr,+        newForeignPtr_,+        mallocForeignPtr,+        mallocPlainForeignPtr,+        mallocForeignPtrBytes,+        mallocPlainForeignPtrBytes,+        addForeignPtrFinalizer, +        touchForeignPtr,+        unsafeForeignPtrToPtr,+        castForeignPtr,+        newConcForeignPtr,+        addForeignPtrConcFinalizer,+        finalizeForeignPtr+  ) where++import Control.Monad    ( sequence_ )+import Foreign.Storable+import Data.Typeable++import GHC.Show+import GHC.List         ( null )+import GHC.Base+import GHC.IOBase+import GHC.STRef        ( STRef(..) )+import GHC.Ptr          ( Ptr(..), FunPtr )+import GHC.Err++#include "Typeable.h"++-- |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+        -- we cache the Addr# in the ForeignPtr object, but attach+        -- the finalizer to the IORef (or the MutableByteArray# in+        -- the case of a MallocPtr).  The aim of the representation+        -- 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.  Note+        -- that touchForeignPtr only has to touch the ForeignPtrContents+        -- object, because that ensures that whatever the finalizer is+        -- attached to is kept alive.++INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")++data ForeignPtrContents+  = PlainForeignPtr !(IORef [IO ()])+  | MallocPtr      (MutableByteArray# RealWorld) !(IORef [IO ()])+  | PlainPtr       (MutableByteArray# RealWorld)++instance Eq (ForeignPtr a) where+    p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q++instance Ord (ForeignPtr a) where+    compare p q  =  compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)++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.+-- +type FinalizerPtr a = FunPtr (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 'newForeignPtr'+-- with a finalizer.+-- +mallocForeignPtr = doMalloc undefined+  where doMalloc :: Storable b => b -> IO (ForeignPtr b)+        doMalloc a = do+          r <- newIORef []+          IO $ \s ->+            case newPinnedByteArray# size s of { (# s', mbarr# #) ->+             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                               (MallocPtr mbarr# r) #)+            }+            where (I# size) = sizeOf 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 (I# size) = do +  r <- newIORef []+  IO $ \s ->+     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# 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 = IO $ \s ->+            case newPinnedByteArray# size s of { (# s', mbarr# #) ->+             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))+                               (PlainPtr mbarr#) #)+            }+            where (I# size) = sizeOf 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 (I# size) = IO $ \s ->+    case newPinnedByteArray# size s      of { (# s', mbarr# #) ->+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# 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 finalizer fptr = +  addForeignPtrConcFinalizer fptr +        (mkFinalizer finalizer (unsafeForeignPtrToPtr fptr))++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, 'Handle's+-- are finalized objects, so a finalizer should not refer to a 'Handle'+-- (including @stdout@, @stdin@ or @stderr@).+--+addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = +  addForeignPtrConcFinalizer_ c finalizer++addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO ()+addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do+  fs <- readIORef r+  writeIORef r (finalizer : fs)+  if (null fs)+     then IO $ \s ->+              case r of { IORef (STRef r#) ->+              case mkWeak# r# () (foreignPtrFinalizer r) s of {  (# s1, _ #) ->+              (# s1, () #) }}+     else return ()+addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do +  fs <- readIORef r+  writeIORef r (finalizer : fs)+  if (null fs)+     then  IO $ \s -> +               case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of+                  (# s1, _ #) -> (# s1, () #)+     else return ()++addForeignPtrConcFinalizer_ _ _ =+  error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"++foreign import ccall "dynamic" +  mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()++foreignPtrFinalizer :: IORef [IO ()] -> IO ()+foreignPtrFinalizer r = do fs <- readIORef r; sequence_ fs++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 []+  return (ForeignPtr obj (PlainForeignPtr 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. In particular 'Foreign.ForeignPtr.withForeignPtr'+-- does a 'touchForeignPtr' after it+-- executes the user action.+-- +-- 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 later 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 f = unsafeCoerce# f++-- | Causes the finalizers associated with a foreign pointer to be run+-- immediately.+finalizeForeignPtr :: ForeignPtr a -> IO ()+finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect+finalizeForeignPtr (ForeignPtr _ foreignPtr) = do+        finalizers <- readIORef refFinalizers+        sequence_ finalizers+        writeIORef refFinalizers []+        where+                refFinalizers = case foreignPtr of+                        (PlainForeignPtr ref) -> ref+                        (MallocPtr     _ ref) -> ref+                        PlainPtr _            ->+                            error "finalizeForeignPtr PlainPtr"+
GHC/Handle.hs view
@@ -1,52 +1,1830 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module GHC.Handle (-  withHandle, withHandle', withHandle_,-  wantWritableHandle, wantReadableHandle, wantSeekableHandle,--  --newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,-  --flushWriteBufferOnly, -  flushWriteBuffer, --flushReadBuffer,-  --fillReadBuffer, fillReadBufferWithoutBlocking,-  --readRawBuffer, readRawBufferPtr,-  --readRawBufferNoBlock, readRawBufferPtrNoBlock,-  --writeRawBuffer, writeRawBufferPtr,--#ifndef mingw32_HOST_OS-  unlockFile,-#endif--  ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,--  stdin, stdout, stderr,-  IOMode(..), openFile, openBinaryFile,-  --fdToHandle_stat, -  fdToHandle, fdToHandle',-  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,-  -- hLookAhead', -  hFlush, hDuplicate, hDuplicateTo,--  hClose, hClose_help,--  HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,-  SeekMode(..), hSeek, hTell,--  hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,-  hSetEcho, hGetEcho, hIsTerminalDevice,--  hShow,-- ) where--import "base" GHC.IO.IOMode-import "base" GHC.IO.Handle-import "base" GHC.IO.Handle.Internals-import "base" GHC.IO.Handle.FD-#ifndef mingw32_HOST_OS-import "base" Foreign.C-#endif--#ifndef mingw32_HOST_OS-foreign import ccall unsafe "unlockFile"-  unlockFile :: CInt -> IO CInt-#endif-+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_HADDOCK hide #-}++#undef DEBUG_DUMP+#undef DEBUG++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Handle+-- 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\".+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Handle (+  withHandle, withHandle', withHandle_,+  wantWritableHandle, wantReadableHandle, wantSeekableHandle,++  newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,+  flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,+  fillReadBuffer, fillReadBufferWithoutBlocking,+  readRawBuffer, readRawBufferPtr,+  readRawBufferNoBlock, readRawBufferPtrNoBlock,+  writeRawBuffer, writeRawBufferPtr,++#ifndef mingw32_HOST_OS+  unlockFile,+#endif++  ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,++  stdin, stdout, stderr,+  IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',+  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode,+  hFlush, hDuplicate, hDuplicateTo,++  hClose, hClose_help,++  HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,+  SeekMode(..), hSeek, hTell,++  hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,+  hSetEcho, hGetEcho, hIsTerminalDevice,++  hShow,++#ifdef DEBUG_DUMP+  puts,+#endif++ ) where++import Control.Monad+import Data.Maybe+import Foreign+import Foreign.C+import System.IO.Error+import System.Posix.Internals+import System.Posix.Types++import GHC.Real++import GHC.Arr+import GHC.Base+import GHC.Read         ( Read )+import GHC.List+import GHC.IOBase+import GHC.Exception+import GHC.Enum+import GHC.Num          ( Integer, Num(..) )+import GHC.Show+#if defined(DEBUG_DUMP)+import GHC.Pack+#endif++import GHC.Conc++-- -----------------------------------------------------------------------------+-- TODO:++-- hWaitForInput blocks (should use a timeout)++-- unbuffered hGetLine is a bit dodgy++-- hSetBuffering: can't change buffering on a stream, +--      when the read buffer is non-empty? (no way to flush the buffer)++-- ---------------------------------------------------------------------------+-- 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++-- ---------------------------------------------------------------------------+-- Creating a new handle++newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle+newFileHandle filepath finalizer hc = do+  m <- newMVar hc+  addMVarFinalizer m (finalizer m)+  return (FileHandle filepath 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 [ this is the case at the moment,+but we might want to revisit this in the future --SDM ].+-}++{-# 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 =+   block $ do+   h_ <- takeMVar m+   checkBufferInvariants h_+   (h',v)  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)+              `catchException` \ex -> ioError (augmentIOError ex fun h)+   checkBufferInvariants 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 =+   block $ do+   h_ <- takeMVar m+   checkBufferInvariants h_+   v  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)+         `catchException` \ex -> ioError (augmentIOError ex fun h)+   checkBufferInvariants h_+   putMVar m h_+   return v++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 =+   block $ do+   h_ <- takeMVar m+   checkBufferInvariants h_+   h'  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)+          `catchException` \ex -> ioError (augmentIOError ex fun h)+   checkBufferInvariants h'+   putMVar m h'+   return ()++augmentIOError :: IOException -> String -> Handle -> IOException+augmentIOError (IOError _ iot _ str fp) fun h+  = IOError (Just h) iot fun str filepath+  where filepath+          | Just _ <- fp = fp+          | otherwise = case h of+                          FileHandle path _     -> Just path+                          DuplexHandle path _ _ -> Just path++-- ---------------------------------------------------------------------------+-- Wrapper for write operations.++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+  -- ToDo: in the Duplex case, we don't need to checkWritableHandle++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 handle_+  = case haType handle_ of+      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      ReadHandle           -> ioe_notWritable+      ReadWriteHandle      -> do+                let ref = haBuffer handle_+                buf <- readIORef ref+                new_buf <-+                  if not (bufferIsWritable buf)+                     then do b <- flushReadBuffer (haFD handle_) buf+                             return b{ bufState=WriteBuffer }+                     else return buf+                writeIORef ref new_buf+                act handle_+      _other               -> act handle_++-- ---------------------------------------------------------------------------+-- Wrapper for read operations.++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+  -- ToDo: in the Duplex case, we don't need to checkReadableHandle++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 handle_ =+    case haType handle_ of+      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      AppendHandle         -> ioe_notReadable+      WriteHandle          -> ioe_notReadable+      ReadWriteHandle      -> do+        let ref = haBuffer handle_+        buf <- readIORef ref+        when (bufferIsWritable buf) $ do+           new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf+           writeIORef ref new_buf{ bufState=ReadBuffer }+        act handle_+      _other               -> act handle_++-- ---------------------------------------------------------------------------+-- 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)+wantSeekableHandle fun h@(FileHandle _ m) act =+  withHandle_' fun h m (checkSeekableHandle act)++checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a+checkSeekableHandle act handle_ =+    case haType handle_ of+      ClosedHandle      -> ioe_closedHandle+      SemiClosedHandle  -> ioe_closedHandle+      AppendHandle      -> ioe_notSeekable+      _  | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_+         | otherwise                                 -> ioe_notSeekable_notBin++-- -----------------------------------------------------------------------------+-- Handy IOErrors++ioe_closedHandle, ioe_EOF,+  ioe_notReadable, ioe_notWritable,+  ioe_notSeekable, ioe_notSeekable_notBin :: IO a++ioe_closedHandle = ioException+   (IOError Nothing IllegalOperation ""+        "handle is closed" Nothing)+ioe_EOF = ioException+   (IOError Nothing EOF "" "" Nothing)+ioe_notReadable = ioException+   (IOError Nothing IllegalOperation ""+        "handle is not open for reading" Nothing)+ioe_notWritable = ioException+   (IOError Nothing IllegalOperation ""+        "handle is not open for writing" Nothing)+ioe_notSeekable = ioException+   (IOError Nothing IllegalOperation ""+        "handle is not seekable" Nothing)+ioe_notSeekable_notBin = ioException+   (IOError Nothing IllegalOperation ""+      "seek operations on text-mode handles are not allowed on this platform"+        Nothing)++ioe_finalizedHandle :: FilePath -> Handle__+ioe_finalizedHandle fp = throw+   (IOError Nothing IllegalOperation ""+        "handle is finalized" (Just fp))++ioe_bufsiz :: Int -> IO a+ioe_bufsiz n = ioException+   (IOError Nothing InvalidArgument "hSetBuffering"+        ("illegal buffer size " ++ showsPrec 9 n []) Nothing)+                                -- 9 => should be parens'ified.++-- -----------------------------------------------------------------------------+-- 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.++stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()+stdHandleFinalizer fp m = do+  h_ <- takeMVar m+  flushWriteBufferOnly h_+  putMVar m (ioe_finalizedHandle fp)++handleFinalizer :: FilePath -> MVar Handle__ -> IO ()+handleFinalizer fp m = do+  handle_ <- takeMVar m+  case haType handle_ of+      ClosedHandle -> return ()+      _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()+                -- ignore errors and async exceptions, and close the+                -- descriptor anyway...+              hClose_handle_ handle_+              return ()+  putMVar m (ioe_finalizedHandle fp)++-- ---------------------------------------------------------------------------+-- Grimy buffer operations++checkBufferInvariants :: Handle__ -> IO ()+#ifdef DEBUG+checkBufferInvariants h_ = do+ let ref = haBuffer h_+ Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref+ if not (+        size > 0+        && r <= w+        && w <= size+        && ( r /= w || (r == 0 && w == 0) )+        && ( state /= WriteBuffer || r == 0 )+        && ( state /= WriteBuffer || w < size ) -- write buffer is never full+     )+   then error "buffer invariant violation"+   else return ()+#else+checkBufferInvariants _ = return ()+#endif++newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer+newEmptyBuffer b state size+  = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }++allocateBuffer :: Int -> BufferState -> IO Buffer+allocateBuffer sz@(I# size) state = IO $ \s -> +   -- We sometimes need to pass the address of this buffer to+   -- a "safe" foreign call, hence it must be immovable.+  case newPinnedByteArray# size s of { (# s', b #) ->+  (# s', newEmptyBuffer b state sz #) }++writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int+writeCharIntoBuffer slab (I# off) (C# c)+  = IO $ \s -> case writeCharArray# slab off c s of +               s' -> (# s', I# (off +# 1#) #)++readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)+readCharFromBuffer slab (I# off)+  = IO $ \s -> case readCharArray# slab off s of +                 (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #)++getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)+getBuffer fd state = do+  buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state+  ioref  <- newIORef buffer+  is_tty <- fdIsTTY fd++  let buffer_mode +         | is_tty    = LineBuffering +         | otherwise = BlockBuffering Nothing++  return (ioref, buffer_mode)++mkUnBuffer :: IO (IORef Buffer)+mkUnBuffer = do+  buffer <- allocateBuffer 1 ReadBuffer+  newIORef buffer++-- flushWriteBufferOnly flushes the buffer iff it contains pending write data.+flushWriteBufferOnly :: Handle__ -> IO ()+flushWriteBufferOnly h_ = do+  let fd = haFD h_+      ref = haBuffer h_+  buf <- readIORef ref+  new_buf <- if bufferIsWritable buf +                then flushWriteBuffer fd (haIsStream h_) buf +                else return buf+  writeIORef ref new_buf++-- flushBuffer syncs the file with the buffer, including moving the+-- file pointer backwards in the case of a read buffer.+flushBuffer :: Handle__ -> IO ()+flushBuffer h_ = do+  let ref = haBuffer h_+  buf <- readIORef ref++  flushed_buf <-+    case bufState buf of+      ReadBuffer  -> flushReadBuffer  (haFD h_) buf+      WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf++  writeIORef ref flushed_buf++-- When flushing a 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.++flushReadBuffer :: FD -> Buffer -> IO Buffer+flushReadBuffer fd buf+  | bufferEmpty buf = return buf+  | otherwise = do+     let off = negate (bufWPtr buf - bufRPtr buf)+#    ifdef DEBUG_DUMP+     puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")+#    endif+     throwErrnoIfMinus1Retry "flushReadBuffer"+         (c_lseek fd (fromIntegral off) sEEK_CUR)+     return buf{ bufWPtr=0, bufRPtr=0 }++flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer+flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  =+  seq fd $ do -- strictness hack+  let bytes = w - r+#ifdef DEBUG_DUMP+  puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")+#endif+  if bytes == 0+     then return (buf{ bufRPtr=0, bufWPtr=0 })+     else do+  res <- writeRawBuffer "flushWriteBuffer" fd is_stream b +                        (fromIntegral r) (fromIntegral bytes)+  let res' = fromIntegral res+  if res' < bytes +     then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })+     else return buf{ bufRPtr=0, bufWPtr=0 }++fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer+fillReadBuffer fd is_line is_stream+      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =+  -- buffer better be empty:+  assert (r == 0 && w == 0) $ do+  fillReadBufferLoop fd is_line is_stream buf b w size++-- For a line buffer, we just get the first chunk of data to arrive,+-- and don't wait for the whole buffer to be full (but we *do* wait+-- until some data arrives).  This isn't really line buffering, but it+-- appears to be what GHC has done for a long time, and I suspect it+-- is more useful than line buffering in most cases.++fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int+                   -> IO Buffer+fillReadBufferLoop fd is_line is_stream buf b w size = do+  let bytes = size - w+  if bytes == 0  -- buffer full?+     then return buf{ bufRPtr=0, bufWPtr=w }+     else do+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")+#endif+  res <- readRawBuffer "fillReadBuffer" fd is_stream b+                       (fromIntegral w) (fromIntegral bytes)+  let res' = fromIntegral res+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoop:  res' = " ++ show res' ++ "\n")+#endif+  if res' == 0+     then if w == 0+             then ioe_EOF+             else return buf{ bufRPtr=0, bufWPtr=w }+     else if res' < bytes && not is_line+             then fillReadBufferLoop fd is_line is_stream buf b (w+res') size+             else return buf{ bufRPtr=0, bufWPtr=w+res' }+ ++fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer+fillReadBufferWithoutBlocking fd is_stream+      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =+  -- buffer better be empty:+  assert (r == 0 && w == 0) $ do+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")+#endif+  res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b+                       0 (fromIntegral size)+  let res' = fromIntegral res+#ifdef DEBUG_DUMP+  puts ("fillReadBufferLoopNoBlock:  res' = " ++ show res' ++ "\n")+#endif+  return buf{ bufRPtr=0, bufWPtr=res' }+ +-- Low level routines for reading/writing to (raw)buffers:++#ifndef 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.++-}++readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBuffer loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- throwErrnoIfMinus1 loc +                                (unsafe_fdReady (fromIntegral fd) 0 0 0)+                      if r /= 0+                        then read+                        else do threadWaitRead (fromIntegral fd); read+  where+    do_read call = throwErrnoIfMinus1RetryMayBlock loc call +                            (threadWaitRead (fromIntegral fd))+    read        = if threaded then safe_read else unsafe_read+    unsafe_read = do_read (read_rawBuffer fd buf off len)+    safe_read   = do_read (safe_read_rawBuffer fd buf off len)++readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtr loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- throwErrnoIfMinus1 loc +                                (unsafe_fdReady (fromIntegral fd) 0 0 0)+                      if r /= 0 +                        then read+                        else do threadWaitRead (fromIntegral fd); read+  where+    do_read call = throwErrnoIfMinus1RetryMayBlock loc call +                            (threadWaitRead (fromIntegral fd))+    read        = if threaded then safe_read else unsafe_read+    unsafe_read = do_read (read_off fd buf off len)+    safe_read   = do_read (safe_read_off fd buf off len)++readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBufferNoBlock loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0+                      if r /= 0 then safe_read+                                else return 0+       -- XXX see note [nonblock]+ where+   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)+   unsafe_read  = do_read (read_rawBuffer fd buf off len)+   safe_read    = do_read (safe_read_rawBuffer fd buf off len)++readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtrNoBlock loc fd is_nonblock buf off len+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0+                      if r /= 0 then safe_read+                                else return 0+       -- XXX see note [nonblock]+ where+   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)+   unsafe_read  = do_read (read_off fd buf off len)+   safe_read    = do_read (safe_read_off fd buf off len)++writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+writeRawBuffer loc fd is_nonblock buf off len+  | is_nonblock = unsafe_write -- unsafe is ok, it can't block+  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0+                     if r /= 0 +                        then write+                        else do threadWaitWrite (fromIntegral fd); write+  where  +    do_write call = throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral fd)) +    write        = if threaded then safe_write else unsafe_write+    unsafe_write = do_write (write_rawBuffer fd buf off len)+    safe_write   = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)++writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+writeRawBufferPtr loc fd is_nonblock buf off len+  | is_nonblock = unsafe_write -- unsafe is ok, it can't block+  | otherwise   = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0+                     if r /= 0 +                        then write+                        else do threadWaitWrite (fromIntegral fd); write+  where+    do_write call = throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral fd)) +    write         = if threaded then safe_write else unsafe_write+    unsafe_write  = do_write (write_off fd buf off len)+    safe_write    = do_write (safe_write_off (fromIntegral fd) buf off len)++foreign import ccall unsafe "__hscore_PrelHandle_read"+   read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall unsafe "__hscore_PrelHandle_read"+   read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall unsafe "__hscore_PrelHandle_write"+   write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall unsafe "__hscore_PrelHandle_write"+   write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall unsafe "fdReady"+  unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt++#else /* mingw32_HOST_OS.... */++readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBuffer loc fd is_stream buf off len+  | threaded  = blockingReadRawBuffer loc fd is_stream buf off len+  | otherwise = asyncReadRawBuffer loc fd is_stream buf off len++readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtr loc fd is_stream buf off len+  | threaded  = blockingReadRawBufferPtr loc fd is_stream buf off len+  | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len++writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+writeRawBuffer loc fd is_stream buf off len+  | threaded =  blockingWriteRawBuffer loc fd is_stream buf off len+  | otherwise = asyncWriteRawBuffer    loc fd is_stream buf off len++writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+writeRawBufferPtr loc fd is_stream buf off len+  | threaded  = blockingWriteRawBufferPtr loc fd is_stream buf off len+  | otherwise = asyncWriteRawBufferPtr    loc fd is_stream buf off len++-- ToDo: we don't have a non-blocking primitve read on Win32+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt+readRawBufferNoBlock = readRawBuffer++readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt+readRawBufferPtrNoBlock = readRawBufferPtr+-- Async versions of the read/write primitives, for the non-threaded RTS++asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt+                   -> IO CInt+asyncReadRawBuffer loc fd is_stream buf off len = do+    (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) +                 (fromIntegral len) off buf+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt+                      -> IO CInt+asyncReadRawBufferPtr loc fd is_stream buf off len = do+    (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) +                        (fromIntegral len) (buf `plusPtr` off)+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt+                    -> IO CInt+asyncWriteRawBuffer loc fd is_stream buf off len = do+    (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) +                        (fromIntegral len) off buf+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt+                       -> IO CInt+asyncWriteRawBufferPtr loc fd is_stream buf off len = do+    (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) +                  (fromIntegral len) (buf `plusPtr` off)+    if l == (-1)+      then +        ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)+      else return (fromIntegral l)++-- Blocking versions of the read/write primitives, for the threaded RTS++blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt+                      -> IO CInt+blockingReadRawBuffer loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_recv_rawBuffer fd buf off len+blockingReadRawBuffer loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_read_rawBuffer fd buf off len++blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt+                         -> IO CInt+blockingReadRawBufferPtr loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_recv_off fd buf off len+blockingReadRawBufferPtr loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_read_off fd buf off len++blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt+                       -> IO CInt+blockingWriteRawBuffer loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_send_rawBuffer fd buf off len+blockingWriteRawBuffer loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_write_rawBuffer fd buf off len++blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt+                          -> IO CInt+blockingWriteRawBufferPtr loc fd True buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_send_off fd buf off len+blockingWriteRawBufferPtr loc fd False buf off len = +  throwErrnoIfMinus1Retry loc $+    safe_write_off fd buf off len++-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.+-- These calls may block, but that's ok.++foreign import ccall safe "__hscore_PrelHandle_recv"+   safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_recv"+   safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_send"+   safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_send"+   safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++#endif++foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool++foreign import ccall safe "__hscore_PrelHandle_read"+   safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_read"+   safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_write"+   safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt++foreign import ccall safe "__hscore_PrelHandle_write"+   safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt++-- ---------------------------------------------------------------------------+-- 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.++fd_stdin, fd_stdout, fd_stderr :: FD+fd_stdin  = 0+fd_stdout = 1+fd_stderr = 2++-- | A handle managing input from the Haskell program's standard input channel.+stdin :: Handle+stdin = unsafePerformIO $ do+   -- ToDo: acquire lock+   -- 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]+   (buf, bmode) <- getBuffer fd_stdin ReadBuffer+   mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode++-- | A handle managing output to the Haskell program's standard output channel.+stdout :: Handle+stdout = unsafePerformIO $ do+   -- ToDo: acquire lock+   -- 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]+   (buf, bmode) <- getBuffer fd_stdout WriteBuffer+   mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode++-- | A handle managing output to the Haskell program's standard error channel.+stderr :: Handle+stderr = unsafePerformIO $ do+    -- ToDo: acquire lock+   -- 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]+   buf <- mkUnBuffer+   mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering++-- ---------------------------------------------------------------------------+-- Opening and Closing Files++addFilePathToIOError :: String -> FilePath -> IOException -> IOException+addFilePathToIOError fun fp (IOError h iot _ str _)+  = IOError h iot fun str (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 = +  catch +    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)+    (\e -> ioError (addFilePathToIOError "openFile" 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 =+  catch+    (openFile' fp m True)+    (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))++openFile' :: String -> IOMode -> Bool -> IO Handle+openFile' filepath mode binary =+  withCString filepath $ \ f ->++    let +      oflags1 = case mode of+                  ReadMode      -> read_flags+#ifdef mingw32_HOST_OS+                  WriteMode     -> write_flags .|. o_TRUNC+#else+                  WriteMode     -> write_flags+#endif+                  ReadWriteMode -> rw_flags+                  AppendMode    -> append_flags++      binary_flags+          | binary    = o_BINARY+          | otherwise = 0++      oflags = oflags1 .|. binary_flags+    in do++    -- the old implementation had a complicated series of three opens,+    -- which is perhaps because we have to be careful not to open+    -- directories.  However, the man pages I've read say that open()+    -- always returns EISDIR if the file is a directory and was opened+    -- for writing, so I think we're ok with a single open() here...+    fd <- throwErrnoIfMinus1Retry "openFile"+                (c_open f (fromIntegral oflags) 0o666)++    stat@(fd_type,_,_) <- fdStat fd++    h <- fdToHandle_stat fd (Just stat) False filepath mode binary+            `catchAny` \e -> do c_close fd; throw e+        -- NB. don't forget to close the FD if fdToHandle' fails, otherwise+        -- this FD leaks.+        -- 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).++#ifndef mingw32_HOST_OS+        -- 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.+    if mode == WriteMode && fd_type == RegularFile+      then throwErrnoIf (/=0) "openFile" +              (c_ftruncate fd 0)+      else return 0+#endif+    return h+++std_flags, output_flags, read_flags, write_flags, rw_flags,+    append_flags :: CInt+std_flags    = o_NONBLOCK   .|. 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++-- ---------------------------------------------------------------------------+-- fdToHandle++fdToHandle_stat :: FD+            -> Maybe (FDType, CDev, CIno)+            -> Bool+            -> FilePath+            -> IOMode+            -> Bool+            -> IO Handle++fdToHandle_stat fd mb_stat is_socket filepath mode binary = do++#ifdef mingw32_HOST_OS+    -- On Windows, the is_socket flag indicates that the Handle is a socket+#else+    -- On Unix, the is_socket flag indicates that the FD can be made non-blocking+    let non_blocking = is_socket++    when non_blocking $ setNonBlockingFD fd+    -- turn on non-blocking mode+#endif++    let (ha_type, write) =+          case mode of+            ReadMode      -> ( ReadHandle,      False )+            WriteMode     -> ( WriteHandle,     True )+            ReadWriteMode -> ( ReadWriteHandle, True )+            AppendMode    -> ( AppendHandle,    True )++    -- open() won't tell us if it was a directory if we only opened for+    -- reading, so check again.+    (fd_type,dev,ino) <- +      case mb_stat of+        Just x  -> return x+        Nothing -> fdStat fd++    case fd_type of+        Directory -> +           ioException (IOError Nothing InappropriateType "openFile"+                           "is a directory" Nothing) ++        -- regular files need to be locked+        RegularFile -> do+#ifndef mingw32_HOST_OS+           -- On Windows we use explicit exclusion via sopen() to implement+           -- this locking (see __hscore_open()); on Unix we have to+           -- implment it in the RTS.+           r <- lockFile fd dev ino (fromBool write)+           when (r == -1)  $+                ioException (IOError Nothing ResourceBusy "openFile"+                                   "file is locked" Nothing)+#endif+           mkFileHandle fd is_socket filepath ha_type binary++        Stream+           -- only *Streams* can be DuplexHandles.  Other read/write+           -- Handles must share a buffer.+           | ReadWriteHandle <- ha_type -> +                mkDuplexHandle fd is_socket filepath binary+           | otherwise ->+                mkFileHandle   fd is_socket filepath ha_type binary++        RawDevice -> +                mkFileHandle fd is_socket filepath ha_type binary++-- | Old API kept to avoid breaking clients+fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath  -> IOMode -> Bool+            -> IO Handle+fdToHandle' fd mb_type is_socket filepath mode binary+ = do+       let mb_stat = case mb_type of+                        Nothing          -> Nothing+                          -- fdToHandle_stat will do the stat:+                        Just RegularFile -> Nothing+                          -- no stat required for streams etc.:+                        Just other       -> Just (other,0,0)+       fdToHandle_stat fd mb_stat is_socket filepath mode binary++fdToHandle :: FD -> IO Handle+fdToHandle fd = do+   mode <- fdGetMode fd+   let fd_str = "<file descriptor: " ++ show fd ++ ">"+   fdToHandle_stat fd Nothing False fd_str mode True{-bin mode-}+        -- NB. the is_socket flag is False, meaning that:+        --  on Unix the file descriptor will *not* be put in non-blocking mode+        --  on Windows we're guessing this is not a socket (XXX)++#ifndef mingw32_HOST_OS+foreign import ccall unsafe "lockFile"+  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt++foreign import ccall unsafe "unlockFile"+  unlockFile :: CInt -> IO CInt+#endif++mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode+        -> IO Handle+mkStdHandle fd filepath ha_type buf bmode = do+   spares <- newIORef BufferListNil+   newFileHandle filepath (stdHandleFinalizer filepath)+            (Handle__ { haFD = fd,+                        haType = ha_type,+                        haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,+                        haIsStream = False, -- means FD is blocking on Unix+                        haBufferMode = bmode,+                        haBuffer = buf,+                        haBuffers = spares,+                        haOtherSide = Nothing+                      })++mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle+mkFileHandle fd is_stream filepath ha_type binary = do+  (buf, bmode) <- getBuffer fd (initBufferState ha_type)++#ifdef mingw32_HOST_OS+  -- On Windows, if this is a read/write handle and we are in text mode,+  -- turn off buffering.  We don't correctly handle the case of switching+  -- from read mode to write mode on a buffered text-mode handle, see bug+  -- \#679.+  bmode2 <- case ha_type of+                 ReadWriteHandle | not binary -> return NoBuffering+                 _other                       -> return bmode+#else+  let bmode2 = bmode+#endif++  spares <- newIORef BufferListNil+  newFileHandle filepath (handleFinalizer filepath)+            (Handle__ { haFD = fd,+                        haType = ha_type,+                        haIsBin = binary,+                        haIsStream = is_stream,+                        haBufferMode = bmode2,+                        haBuffer = buf,+                        haBuffers = spares,+                        haOtherSide = Nothing+                      })++mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle+mkDuplexHandle fd is_stream filepath binary = do+  (w_buf, w_bmode) <- getBuffer fd WriteBuffer+  w_spares <- newIORef BufferListNil+  let w_handle_ = +             Handle__ { haFD = fd,+                        haType = WriteHandle,+                        haIsBin = binary,+                        haIsStream = is_stream,+                        haBufferMode = w_bmode,+                        haBuffer = w_buf,+                        haBuffers = w_spares,+                        haOtherSide = Nothing+                      }+  write_side <- newMVar w_handle_++  (r_buf, r_bmode) <- getBuffer fd ReadBuffer+  r_spares <- newIORef BufferListNil+  let r_handle_ = +             Handle__ { haFD = fd,+                        haType = ReadHandle,+                        haIsBin = binary,+                        haIsStream = is_stream,+                        haBufferMode = r_bmode,+                        haBuffer = r_buf,+                        haBuffers = r_spares,+                        haOtherSide = Just write_side+                      }+  read_side <- newMVar r_handle_++  addMVarFinalizer write_side (handleFinalizer filepath write_side)+  return (DuplexHandle filepath read_side write_side)+   +initBufferState :: HandleType -> BufferState+initBufferState ReadHandle = ReadBuffer+initBufferState _          = WriteBuffer++-- ---------------------------------------------------------------------------+-- 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 :: Handle -> IO ()+hClose h@(FileHandle _ m)     = do +  mb_exc <- hClose' h m+  case mb_exc of+    Nothing -> return ()+    Just e  -> throwIO e+hClose h@(DuplexHandle _ r w) = do+  mb_exc1 <- hClose' h w+  mb_exc2 <- hClose' h r+  case (do mb_exc1; mb_exc2) of+     Nothing -> return ()+     Just e  -> 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 PrelIO) 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 flushWriteBufferOnly handle_ -- interruptible+              hClose_handle_ handle_++hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)+hClose_handle_ handle_ = do+    let fd = haFD handle_++    -- 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 handle_ of+        Nothing -> (do+                      throwErrnoIfMinus1Retry_ "hClose" +#ifdef mingw32_HOST_OS+                                (closeFd (haIsStream handle_) fd)+#else+                                (c_close fd)+#endif+                      return Nothing+                    )+                     `catchException` \e -> return (Just e)++        Just _  -> return Nothing++    -- free the spare buffers+    writeIORef (haBuffers handle_) BufferListNil+    writeIORef (haBuffer  handle_) noBuffer+  +#ifndef mingw32_HOST_OS+    -- unlock it+    unlockFile fd+#endif++    -- we must set the fd to -1, because the finalizer is going+    -- to run eventually and try to close/unlock it.+    return (handle_{ haFD        = -1, +                     haType      = ClosedHandle+                   },+            maybe_exception)++{-# NOINLINE noBuffer #-}+noBuffer :: Buffer+noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer++-----------------------------------------------------------------------------+-- 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_ -> do+    case haType handle_ of +      ClosedHandle              -> ioe_closedHandle+      SemiClosedHandle          -> ioe_closedHandle+      _ -> do flushWriteBufferOnly handle_+              r <- fdFileSize (haFD handle_)+              if r /= -1+                 then return r+                 else ioException (IOError Nothing InappropriateType "hFileSize"+                                   "not a regular file" 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_ -> do+    case haType handle_ of +      ClosedHandle              -> ioe_closedHandle+      SemiClosedHandle          -> ioe_closedHandle+      _ -> do flushWriteBufferOnly handle_+              throwErrnoIf (/=0) "hSetFileSize" +                 (c_ftruncate (haFD handle_) (fromIntegral 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 is the same as calling+-- 'hLookAhead' and checking for an EOF exception.++hIsEOF :: Handle -> IO Bool+hIsEOF handle =+  catch+     (do hLookAhead handle; return False)+     (\e -> if isEOFError e then return True else ioError e)++-- | 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:+--+--  * 'isEOFError' if the end of file has been reached.++hLookAhead :: Handle -> IO Char+hLookAhead handle =+  wantReadableHandle "hLookAhead"  handle hLookAhead'++hLookAhead' :: Handle__ -> IO Char+hLookAhead' handle_ = do+  let ref     = haBuffer handle_+      fd      = haFD handle_+  buf <- readIORef ref++  -- fill up the read buffer if necessary+  new_buf <- if bufferEmpty buf+                then fillReadBuffer fd True (haIsStream handle_) buf+                else return buf++  writeIORef ref new_buf++  (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)+  return c++-- ---------------------------------------------------------------------------+-- Buffering Operations++-- Three kinds of buffering are supported: line-buffering,+-- block-buffering or no-buffering.  See GHC.IOBase 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:+--+--  * '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_ -> do+  case haType handle_ of+    ClosedHandle -> ioe_closedHandle+    _ -> do+         {- Note:+            - we flush the old buffer regardless of whether+              the new buffer could fit the contents of the old buffer +              or not.+            - allow a handle's buffering to change even if IO has+              occurred (ANSI C spec. does not allow this, nor did+              the previous implementation of IO.hSetBuffering).+            - a non-standard extension is to allow the buffering+              of semi-closed handles to change [sof 6/98]+          -}+          flushBuffer handle_++          let state = initBufferState (haType handle_)+          new_buf <-+            case mode of+                -- we always have a 1-character read buffer for +                -- unbuffered  handles: it's needed to +                -- support hLookAhead.+              NoBuffering            -> allocateBuffer 1 ReadBuffer+              LineBuffering          -> allocateBuffer dEFAULT_BUFFER_SIZE state+              BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state+              BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n+                                      | otherwise -> allocateBuffer n state+          writeIORef (haBuffer handle_) new_buf++          -- for input terminals we need to put the terminal into+          -- cooked or raw mode depending on the type of buffering.+          is_tty <- fdIsTTY (haFD handle_)+          when (is_tty && isReadableHandleType (haType handle_)) $+                case mode of+#ifndef mingw32_HOST_OS+        -- 'raw' mode under win32 is a bit too specialised (and troublesome+        -- for most common uses), so simply disable its use here.+                  NoBuffering -> setCooked (haFD handle_) False+#else+                  NoBuffering -> return ()+#endif+                  _           -> setCooked (haFD handle_) True++          -- throw away spare buffers, they might be the wrong size+          writeIORef (haBuffers handle_) BufferListNil++          return (handle_{ haBufferMode = mode })++-- -----------------------------------------------------------------------------+-- 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:+--+--  * 'isFullError' if the device is full;+--+--  * '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 $ \ handle_ -> do+   buf <- readIORef (haBuffer handle_)+   if bufferIsWritable buf && not (bufferEmpty buf)+        then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf+                writeIORef (haBuffer handle_) flushed_buf+        else return ()+++-- -----------------------------------------------------------------------------+-- Repositioning Handles++data HandlePosn = HandlePosn Handle HandlePosition++instance Eq HandlePosn where+    (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2++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:+--+--  * 'isPermissionError' if a system resource limit would be exceeded.++hSetPosn :: HandlePosn -> IO () +hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i++-- ---------------------------------------------------------------------------+-- hSeek++-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:+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, Ord, Ix, Enum, Read, Show)++{- 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:+--+--  * 'isPermissionError' if a system resource limit would be exceeded.++hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek handle mode offset =+    wantSeekableHandle "hSeek" handle $ \ handle_ -> do+#   ifdef DEBUG_DUMP+    puts ("hSeek " ++ show (mode,offset) ++ "\n")+#   endif+    let ref = haBuffer handle_+    buf <- readIORef ref+    let r = bufRPtr buf+        w = bufWPtr buf+        fd = haFD handle_++    let do_seek =+          throwErrnoIfMinus1Retry_ "hSeek"+            (c_lseek (haFD handle_) (fromIntegral offset) whence)++        whence :: CInt+        whence = case mode of+                   AbsoluteSeek -> sEEK_SET+                   RelativeSeek -> sEEK_CUR+                   SeekFromEnd  -> sEEK_END++    if bufferIsWritable buf+        then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf+                writeIORef ref new_buf+                do_seek+        else do++    if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)+        then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }+        else do ++    new_buf <- flushReadBuffer (haFD handle_) buf+    writeIORef ref new_buf+    do_seek+++hTell :: Handle -> IO Integer+hTell handle = +    wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do++#if defined(mingw32_HOST_OS)+        -- urgh, on Windows we have to worry about \n -> \r\n translation, +        -- so we can't easily calculate the file position using the+        -- current buffer size.  Just flush instead.+      flushBuffer handle_+#endif+      let fd = haFD handle_+      posn <- fromIntegral `liftM`+                throwErrnoIfMinus1Retry "hGetPosn"+                   (c_lseek fd 0 sEEK_CUR)++      let ref = haBuffer handle_+      buf <- readIORef ref++      let real_posn +           | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)+           | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)+#     ifdef DEBUG_DUMP+      puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")+      puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")+#     endif+      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_closedHandle+      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_closedHandle+      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_ -> do+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      AppendHandle         -> return False+      _                    -> do t <- fdType (haFD handle_)+                                 return ((t == RegularFile    || t == RawDevice)+                                         && (haIsBin handle_  || tEXT_MODE_SEEK_ALLOWED))++-- -----------------------------------------------------------------------------+-- Changing echo status (Non-standard GHC extensions)++-- | 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 handle_ of +         ClosedHandle -> ioe_closedHandle+         _            -> setEcho (haFD handle_) 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 handle_ of +         ClosedHandle -> ioe_closedHandle+         _            -> getEcho (haFD handle_)++-- | Is the handle connected to a terminal?++hIsTerminalDevice :: Handle -> IO Bool+hIsTerminalDevice handle = do+    withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do+     case haType handle_ of +       ClosedHandle -> ioe_closedHandle+       _            -> fdIsTTY (haFD handle_)++-- -----------------------------------------------------------------------------+-- hSetBinaryMode++-- | Select binary mode ('True') or text mode ('False') on a open handle.+-- (See also 'openBinaryFile'.)++hSetBinaryMode :: Handle -> Bool -> IO ()+hSetBinaryMode handle bin =+  withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->+    do throwErrnoIfMinus1_ "hSetBinaryMode"+          (setmode (haFD handle_) bin)+       return handle_{haIsBin=bin}+  +foreign import ccall unsafe "__hscore_setmode"+  setmode :: CInt -> Bool -> IO CInt++-- -----------------------------------------------------------------------------+-- 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) = do+  new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)+  newFileHandle path (handleFinalizer path) new_h_+hDuplicate h@(DuplexHandle path r w) = do+  new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)+  new_w <- newMVar new_w_+  new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))+  new_r <- newMVar new_r_+  addMVarFinalizer new_w (handleFinalizer path new_w)+  return (DuplexHandle path new_r new_w)++dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__+          -> IO (Handle__, Handle__)+dupHandle h other_side h_ = do+  -- flush the buffer first, so we don't have to copy its contents+  flushBuffer h_+  new_fd <- case other_side of+                Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)+                Just r -> withHandle_' "dupHandle" h r (return . haFD)+  dupHandle_ other_side h_ new_fd++dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__+            -> IO (Handle__, Handle__)+dupHandleTo other_side hto_ h_ = do+  flushBuffer h_+  -- Windows' dup2 does not return the new descriptor, unlike Unix+  throwErrnoIfMinus1 "dupHandleTo" $ +        c_dup2 (haFD h_) (haFD hto_)+  dupHandle_ other_side h_ (haFD hto_)++dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD+           -> IO (Handle__, Handle__)+dupHandle_ other_side h_ new_fd = do+  buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))+  ioref <- newIORef buffer+  ioref_buffers <- newIORef BufferListNil++  let new_handle_ = h_{ haFD = new_fd, +                        haBuffer = ioref, +                        haBuffers = ioref_buffers,+                        haOtherSide = other_side }+  return (h_, new_handle_)++-- -----------------------------------------------------------------------------+-- 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 _ m1) h2@(FileHandle _ m2)  = do+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do+   _ <- hClose_help h2_+   withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)+hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do+ withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do+   _ <- hClose_help w2_+   withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)+ withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do+   _ <- hClose_help r2_+   withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)+hDuplicateTo h1 _ =+   ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" +                "handles are incompatible" Nothing)++-- ---------------------------------------------------------------------------+-- 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 "binary=" . shows (haIsBin hdl_) . showChar ',' .+             showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )+      ) "")+   where++    showHdl :: HandleType -> ShowS -> ShowS+    showHdl ht cont = +       case ht of+        ClosedHandle  -> shows ht . showString "}"+        _ -> cont++    showBufMode :: Buffer -> 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++-- ---------------------------------------------------------------------------+-- debugging++#if defined(DEBUG_DUMP)+puts :: String -> IO ()+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))+            return ()+#endif++-- -----------------------------------------------------------------------------+-- utils++throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt+throwErrnoIfMinus1RetryOnBlock loc f on_block  = +  do+    res <- f+    if (res :: CInt) == -1+      then do+        err <- getErrno+        if err == eINTR+          then throwErrnoIfMinus1RetryOnBlock loc f on_block+          else if err == eWOULDBLOCK || err == eAGAIN+                 then do on_block+                 else throwErrno loc+      else return res++-- -----------------------------------------------------------------------------+-- wrappers to platform-specific constants:++foreign import ccall unsafe "__hscore_supportsTextMode"+  tEXT_MODE_SEEK_ALLOWED :: Bool++foreign import ccall unsafe "__hscore_bufsiz"   dEFAULT_BUFFER_SIZE :: Int+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
+ GHC/Handle.hs-boot view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Handle where++import GHC.IOBase++stdout :: Handle+stderr :: Handle+hFlush :: Handle -> IO ()
GHC/IO.hs view
@@ -1,2 +1,974 @@-module GHC.IO (module X___) where-import "base" GHC.IO as X___+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}+{-# OPTIONS_HADDOCK hide #-}++#undef DEBUG_DUMP++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.IO+-- Copyright   :  (c) The University of Glasgow, 1992-2001+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  internal+-- Portability :  non-portable+--+-- String I\/O functions+--+-----------------------------------------------------------------------------++-- #hide+module GHC.IO ( +   hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,+   commitBuffer',       -- hack, see below+   hGetcBuffered,       -- needed by ghc/compiler/utils/StringBuffer.lhs+   hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,+   memcpy_ba_baoff,+   memcpy_ptr_baoff,+   memcpy_baoff_ba,+   memcpy_baoff_ptr,+ ) where++import Foreign+import Foreign.C++import System.IO.Error+import Data.Maybe+import Control.Monad+#ifndef mingw32_HOST_OS+import System.Posix.Internals+#endif++import GHC.Enum+import GHC.Base+import GHC.IOBase+import GHC.Handle       -- much of the real stuff is in here+import GHC.Real+import GHC.Num+import GHC.Show+import GHC.List++#ifdef mingw32_HOST_OS+import GHC.Conc+#endif++-- ---------------------------------------------------------------------------+-- 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.+--+-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.+--+-- This operation may fail with:+--+--  * 'isEOFError' if the end of file has been reached.+--+-- NOTE for GHC users: unless you use the @-threaded@ flag,+-- @hWaitForInput 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 = do+  wantReadableHandle "hWaitForInput" h $ \ handle_ -> do+  let ref = haBuffer handle_+  buf <- readIORef ref++  if not (bufferEmpty buf)+        then return True+        else do++  if msecs < 0 +        then do buf' <- fillReadBuffer (haFD handle_) True +                                (haIsStream handle_) buf+                writeIORef ref buf'+                return True+        else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $+                     fdReady (haFD handle_) 0 {- read -}+                                (fromIntegral msecs)+                                (fromIntegral $ fromEnum $ haIsStream handle_)+                if r /= 0 then do -- Call hLookAhead' to throw an EOF+                                  -- exception if appropriate+                                  hLookAhead' handle_+                                  return True+                          else return False++foreign import ccall safe "fdReady"+  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt++-- ---------------------------------------------------------------------------+-- 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_ -> do++  let fd = haFD handle_+      ref = haBuffer handle_++  buf <- readIORef ref+  if not (bufferEmpty buf)+        then hGetcBuffered fd ref buf+        else do++  -- buffer is empty.+  case haBufferMode handle_ of+    LineBuffering    -> do+        new_buf <- fillReadBuffer fd True (haIsStream handle_) buf+        hGetcBuffered fd ref new_buf+    BlockBuffering _ -> do+        new_buf <- fillReadBuffer fd True (haIsStream handle_) buf+                --                   ^^^^+                -- don't wait for a completely full buffer.+        hGetcBuffered fd ref new_buf+    NoBuffering -> do+        -- make use of the minimal buffer we already have+        let raw = bufBuf buf+        r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1+        if r == 0+           then ioe_EOF+           else do (c,_) <- readCharFromBuffer raw 0+                   return c++hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char+hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w }+ = do (c, r) <- readCharFromBuffer b r0+      let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }+                  | otherwise = buf{ bufRPtr=r }+      writeIORef ref new_buf+      return c++-- ---------------------------------------------------------------------------+-- hGetLine++-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for+-- the duration.++-- | 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 = do+  m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do+        case haBufferMode handle_ of+           NoBuffering      -> return Nothing+           LineBuffering    -> do+              l <- hGetLineBuffered handle_+              return (Just l)+           BlockBuffering _ -> do +              l <- hGetLineBuffered handle_+              return (Just l)+  case m of+        Nothing -> hGetLineUnBuffered h+        Just l  -> return l++hGetLineBuffered :: Handle__ -> IO String+hGetLineBuffered handle_ = do+  let ref = haBuffer handle_+  buf <- readIORef ref+  hGetLineBufferedLoop handle_ ref buf []++hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]+                     -> IO String+hGetLineBufferedLoop handle_ ref+        buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=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') <- readCharFromBuffer 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++#ifdef DEBUG_DUMP+  puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")+#endif++  xs <- unpack raw0 r0 off++  -- if eol == True, then off is the offset of the '\n'+  -- otherwise off == w and the buffer is now empty.+  if eol+        then do if (w == off + 1)+                        then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }+                        else writeIORef ref buf{ bufRPtr = off + 1 }+                return (concat (reverse (xs:xss)))+        else do+             maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)+                                buf{ bufWPtr=0, bufRPtr=0 }+             case maybe_buf of+                -- Nothing indicates we caught an EOF, and we may have a+                -- partial line to return.+                Nothing -> do+                     writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }+                     let str = concat (reverse (xs:xss))+                     if not (null str)+                        then return str+                        else ioe_EOF+                Just new_buf ->+                     hGetLineBufferedLoop handle_ ref new_buf (xs:xss)++maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer)+maybeFillReadBuffer fd is_line is_stream buf+  = catch +     (do buf' <- fillReadBuffer fd is_line is_stream buf+         return (Just buf')+     )+     (\e -> do if isEOFError e +                  then return Nothing +                  else ioError e)+++unpack :: RawBuffer -> Int -> Int -> IO [Char]+unpack _   _      0        = return ""+unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s+   where+    unpackRB acc i s+     | i <# r  = (# s, acc #)+     | otherwise = +          case readCharArray# buf i s of+          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'+++hGetLineUnBuffered :: Handle -> IO String+hGetLineUnBuffered h = do+  c <- hGetChar h+  if c == '\n' then+     return ""+   else do+    l <- getRest+    return (c:l)+ where+  getRest = do+    c <- +      catch +        (hGetChar h)+        (\ err -> do+          if isEOFError err then+             return '\n'+           else+             ioError err)+    if c == '\n' then+       return ""+     else do+       s <- getRest+       return (c:s)++-- -----------------------------------------------------------------------------+-- 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 'hClose'.+-- A semi-closed handle becomes closed:+--+--  * if '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 = +    withHandle "hGetContents" handle $ \handle_ ->+    case haType handle_ of +      ClosedHandle         -> ioe_closedHandle+      SemiClosedHandle     -> ioe_closedHandle+      AppendHandle         -> ioe_notReadable+      WriteHandle          -> ioe_notReadable+      _ -> 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 "lazyRead" handle $ \ handle_ -> do+        case haType handle_ of+          ClosedHandle     -> return (handle_, "")+          SemiClosedHandle -> lazyRead' handle handle_+          _ -> ioException +                  (IOError (Just handle) IllegalOperation "lazyRead"+                        "illegal handle type" Nothing)++lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char])+lazyRead' h handle_ = do+  let ref = haBuffer handle_+      fd  = haFD handle_++  -- even a NoBuffering handle can have a char in the buffer... +  -- (see hLookAhead)+  buf <- readIORef ref+  if not (bufferEmpty buf)+        then lazyReadHaveBuffer h handle_ fd ref buf+        else do++  case haBufferMode handle_ of+     NoBuffering      -> do+        -- make use of the minimal buffer we already have+        let raw = bufBuf buf+        r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1+        if r == 0+           then do (handle_', _) <- hClose_help handle_ +                   return (handle_', "")+           else do (c,_) <- readCharFromBuffer raw 0+                   rest <- lazyRead h+                   return (handle_, c : rest)++     LineBuffering    -> lazyReadBuffered h handle_ fd ref buf+     BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf++-- we never want to block during the read, so we call fillReadBuffer with+-- is_line==True, which tells it to "just read what there is".+lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer+                 -> IO (Handle__, [Char])+lazyReadBuffered h handle_ fd ref buf = do+   catch +        (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf+            lazyReadHaveBuffer h handle_ fd ref buf'+        )+        -- all I/O errors are discarded.  Additionally, we close the handle.+        (\_ -> do (handle_', _) <- hClose_help handle_+                  return (handle_', "")+        )++lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char])+lazyReadHaveBuffer h handle_ _ ref buf = do+   more <- lazyRead h+   writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }+   s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more+   return (handle_, s)+++unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]+unpackAcc _   _      0        acc  = return acc+unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s+   where+    unpackRB acc i s+     | i <# r  = (# s, acc #)+     | otherwise = +          case readCharArray# buf i s of+          (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'++-- ---------------------------------------------------------------------------+-- 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_  -> do+    let fd = haFD handle_+    case haBufferMode handle_ of+        LineBuffering    -> hPutcBuffered handle_ True  c+        BlockBuffering _ -> hPutcBuffered handle_ False c+        NoBuffering      ->+                with (castCharToCChar c) $ \buf -> do+                  writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1+                  return ()++hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()+hPutcBuffered handle_ is_line c = do+  let ref = haBuffer handle_+  buf <- readIORef ref+  let w = bufWPtr buf+  w'  <- writeCharIntoBuffer (bufBuf buf) w c+  let new_buf = buf{ bufWPtr = w' }+  if bufferFull new_buf || is_line && c == '\n'+     then do +        flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf+        writeIORef ref flushed_buf+     else do +        writeIORef ref new_buf+++hPutChars :: Handle -> [Char] -> IO ()+hPutChars _      [] = return ()+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs++-- ---------------------------------------------------------------------------+-- 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 = do+    buffer_mode <- wantWritableHandle "hPutStr" handle +                        (\ handle_ -> do getSpareBuffer handle_)+    case buffer_mode of+       (NoBuffering, _) -> do+            hPutChars handle str        -- v. slow, but we don't care+       (LineBuffering, buf) -> do+            writeLines handle buf str+       (BlockBuffering _, buf) -> do+            writeBlocks handle buf str+++getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)+getSpareBuffer Handle__{haBuffer=ref, +                        haBuffers=spare_ref,+                        haBufferMode=mode}+ = do+   case mode of+     NoBuffering -> return (mode, error "no buffer!")+     _ -> do+          bufs <- readIORef spare_ref+          buf  <- readIORef ref+          case bufs of+            BufferListCons b rest -> do+                writeIORef spare_ref rest+                return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))+            BufferListNil -> do+                new_buf <- allocateBuffer (bufSize buf) WriteBuffer+                return (mode, new_buf)+++writeLines :: Handle -> Buffer -> String -> IO ()+writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =+  let+   shoveString :: Int -> [Char] -> IO ()+        -- check n == len first, to ensure that shoveString is strict in n.+   shoveString n cs | n == len = do+        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False+        writeLines hdl new_buf cs+   shoveString n [] = do+        commitBuffer hdl raw len n False{-no flush-} True{-release-}+        return ()+   shoveString n (c:cs) = do+        n' <- writeCharIntoBuffer raw n c+        if (c == '\n') +         then do +              new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False+              writeLines hdl new_buf cs+         else +              shoveString n' cs+  in+  shoveString 0 s++writeBlocks :: Handle -> Buffer -> String -> IO ()+writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =+  let+   shoveString :: Int -> [Char] -> IO ()+        -- check n == len first, to ensure that shoveString is strict in n.+   shoveString n cs | n == len = do+        new_buf <- commitBuffer hdl raw len n True{-needs flush-} False+        writeBlocks hdl new_buf cs+   shoveString n [] = do+        commitBuffer hdl raw len n False{-no flush-} True{-release-}+        return ()+   shoveString n (c:cs) = do+        n' <- writeCharIntoBuffer raw n c+        shoveString n' cs+  in+  shoveString 0 s++-- -----------------------------------------------------------------------------+-- 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).+-- +-- Implementation:+-- +--    for block/line buffering,+--       1. If there isn't room in the handle buffer, flush the handle+--          buffer.+-- +--       2. If the handle buffer is empty,+--               if flush, +--                   then write buf directly to the device.+--                   else swap the handle buffer with buf.+-- +--       3. If the handle buffer is non-empty, copy buf into the+--          handle buffer.  Then, if flush != 0, flush+--          the buffer.++commitBuffer+        :: Handle                       -- handle to commit to+        -> RawBuffer -> 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 Buffer++commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do+  wantWritableHandle "commitAndReleaseBuffer" hdl $+     commitBuffer' raw sz count flush release++-- Explicitly lambda-lift this function to subvert GHC's full laziness+-- optimisations, which otherwise tends to float out subexpressions+-- past the \handle, which is really a pessimisation in this case because+-- that lambda is a one-shot lambda.+--+-- Don't forget to export the function, to stop it being inlined too+-- (this appears to be better than NOINLINE, because the strictness+-- analyser still gets to worker-wrapper it).+--+-- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001+--+commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__+              -> IO Buffer+commitBuffer' raw sz@(I# _) count@(I# _) flush release+  handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do++#ifdef DEBUG_DUMP+      puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count+            ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")+#endif++      old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }+          <- readIORef ref++      buf_ret <-+        -- enough room in handle buffer?+         if (not flush && (size - w > count))+                -- The > is to be sure that we never exactly fill+                -- up the buffer, which would require a flush.  So+                -- if copying the new data into the buffer would+                -- make the buffer full, we just flush the existing+                -- buffer and the new data immediately, rather than+                -- copying before flushing.++                -- not flushing, and there's enough room in the buffer:+                -- just copy the data in and update bufWPtr.+            then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)+                    writeIORef ref old_buf{ bufWPtr = w + count }+                    return (newEmptyBuffer raw WriteBuffer sz)++                -- else, we have to flush+            else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf++                    let this_buf = +                            Buffer{ bufBuf=raw, bufState=WriteBuffer, +                                    bufRPtr=0, bufWPtr=count, bufSize=sz }++                        -- if:  (a) we don't have to flush, and+                        --      (b) size(new buffer) == size(old buffer), and+                        --      (c) new buffer is not full,+                        -- we can just just swap them over...+                    if (not flush && sz == size && count /= sz)+                        then do +                          writeIORef ref this_buf+                          return flushed_buf                         ++                        -- otherwise, we have to flush the new data too,+                        -- and start with a fresh buffer+                        else do+                          flushWriteBuffer fd (haIsStream handle_) this_buf+                          writeIORef ref flushed_buf+                            -- if the sizes were different, then allocate+                            -- a new buffer of the correct size.+                          if sz == size+                             then return (newEmptyBuffer raw WriteBuffer sz)+                             else allocateBuffer size WriteBuffer++      -- release the buffer if necessary+      case buf_ret of+        Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do+          if release && buf_ret_sz == size+            then do+              spare_bufs <- readIORef spare_buf_ref+              writeIORef spare_buf_ref +                (BufferListCons buf_ret_raw spare_bufs)+              return buf_ret+            else+              return buf_ret++-- ---------------------------------------------------------------------------+-- 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 ().+--+-- 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 $ +      \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> +          bufWrite fd ref is_stream ptr count can_block++bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int+bufWrite fd ref is_stream ptr count can_block =+  seq count $ seq fd $ do  -- strictness hack+  old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }+     <- readIORef ref++  -- enough room in handle buffer?+  if (size - w > count)+        -- There's enough room in the buffer:+        -- just copy the data in and update bufWPtr.+        then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)+                writeIORef ref old_buf{ bufWPtr = w + count }+                return count++        -- else, we have to flush+        else do flushed_buf <- flushWriteBuffer fd is_stream old_buf+                        -- TODO: we should do a non-blocking flush here+                writeIORef ref flushed_buf+                -- if we can fit in the buffer, then just loop  +                if count < size+                   then bufWrite fd ref is_stream ptr count can_block+                   else if can_block+                           then do writeChunk fd is_stream (castPtr ptr) count+                                   return count+                           else writeChunkNonBlocking fd is_stream ptr count++writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()+writeChunk fd is_stream ptr bytes0 = loop 0 bytes0+ where+  loop :: Int -> Int -> IO ()+  loop _   bytes | bytes <= 0 = return ()+  loop off bytes = do+    r <- fromIntegral `liftM`+           writeRawBufferPtr "writeChunk" fd is_stream ptr+                             off (fromIntegral bytes)+    -- write can't return 0+    loop (off + r) (bytes - r)++writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int+writeChunkNonBlocking fd+#ifndef mingw32_HOST_OS+                         _+#else+                         is_stream+#endif+                                   ptr bytes0 = loop 0 bytes0+ where+  loop :: Int -> Int -> IO Int+  loop off bytes | bytes <= 0 = return off+  loop off bytes = do+#ifndef mingw32_HOST_OS+    ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)+    let r = fromIntegral ssize :: Int+    if (r == -1)+      then do errno <- getErrno+              if (errno == eAGAIN || errno == eWOULDBLOCK)+                 then return off+                 else throwErrno "writeChunk"+      else loop (off + r) (bytes - r)+#else+    (ssize, rc) <- asyncWrite (fromIntegral fd)+                              (fromIntegral $ fromEnum is_stream)+                                 (fromIntegral bytes)+                                 (ptr `plusPtr` off)+    let r = fromIntegral ssize :: Int+    if r == (-1)+      then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)+      else loop (off + r) (bytes - r)+#endif++-- ---------------------------------------------------------------------------+-- 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 :: Handle -> Ptr a -> Int -> IO Int+hGetBuf h ptr count+  | count == 0 = return 0+  | count <  0 = illegalBufferSize h "hGetBuf" count+  | otherwise = +      wantReadableHandle "hGetBuf" h $ +        \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do+            bufRead fd ref is_stream ptr 0 count++-- small reads go through the buffer, large reads are satisfied by+-- taking data first from the buffer and then direct from the file+-- descriptor.+bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int+bufRead fd ref is_stream ptr so_far count =+  seq fd $ seq so_far $ seq count $ do -- strictness hack+  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref+  if bufferEmpty buf+     then if count > sz  -- small read?+                then do rest <- readChunk fd is_stream ptr count+                        return (so_far + rest)+                else do mb_buf <- maybeFillReadBuffer fd True is_stream buf+                        case mb_buf of+                          Nothing -> return so_far -- got nothing, we're done+                          Just buf' -> do+                                writeIORef ref buf'+                                bufRead fd ref is_stream ptr so_far count+     else do +        let avail = w - r+        if (count == avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+                return (so_far + count)+           else do+        if (count < avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufRPtr = r + count }+                return (so_far + count)+           else do+  +        memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)+        writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+        let remaining = count - avail+            so_far' = so_far + avail+            ptr' = ptr `plusPtr` avail++        if remaining < sz+           then bufRead fd ref is_stream ptr' so_far' remaining+           else do ++        rest <- readChunk fd is_stream ptr' remaining+        return (so_far' + rest)++readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int+readChunk fd is_stream ptr bytes0 = loop 0 bytes0+ where+  loop :: Int -> Int -> IO Int+  loop off bytes | bytes <= 0 = return off+  loop off bytes = do+    r <- fromIntegral `liftM`+           readRawBufferPtr "readChunk" fd is_stream +                            (castPtr ptr) off (fromIntegral bytes)+    if r == 0+        then return off+        else loop (off + r) (bytes - r)+++-- | '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 :: Handle -> Ptr a -> Int -> IO Int+hGetBufNonBlocking h ptr count+  | count == 0 = return 0+  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count+  | otherwise = +      wantReadableHandle "hGetBufNonBlocking" h $ +        \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do+            bufReadNonBlocking fd ref is_stream ptr 0 count++bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int+                   -> IO Int+bufReadNonBlocking fd ref is_stream ptr so_far count =+  seq fd $ seq so_far $ seq count $ do -- strictness hack+  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref+  if bufferEmpty buf+     then if count > sz  -- large read?+                then do rest <- readChunkNonBlocking fd is_stream ptr count+                        return (so_far + rest)+                else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf+                        case buf' of { Buffer{ bufWPtr=w' }  ->+                        if (w' == 0) +                           then return so_far+                           else do writeIORef ref buf'+                                   bufReadNonBlocking fd ref is_stream ptr+                                         so_far (min count w')+                                  -- NOTE: new count is    min count w'+                                  -- so we will just copy the contents of the+                                  -- buffer in the recursive call, and not+                                  -- loop again.+                        }+     else do+        let avail = w - r+        if (count == avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+                return (so_far + count)+           else do+        if (count < avail)+           then do +                memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)+                writeIORef ref buf{ bufRPtr = r + count }+                return (so_far + count)+           else do++        memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)+        writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }+        let remaining = count - avail+            so_far' = so_far + avail+            ptr' = ptr `plusPtr` avail++        -- we haven't attempted to read anything yet if we get to here.+        if remaining < sz+           then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining+           else do ++        rest <- readChunkNonBlocking fd is_stream ptr' remaining+        return (so_far' + rest)+++readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int+readChunkNonBlocking fd is_stream ptr bytes = do+    fromIntegral `liftM`+        readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream +                            (castPtr ptr) 0 (fromIntegral bytes)++    -- we don't have non-blocking read support on Windows, so just invoke+    -- the ordinary low-level read which will block until data is available,+    -- but won't wait for the whole buffer to fill.++slurpFile :: FilePath -> IO (Ptr (), Int)+slurpFile fname = do+  handle <- openFile fname ReadMode+  sz     <- hFileSize handle+  if sz > fromIntegral (maxBound::Int) then +    ioError (userError "slurpFile: file too big")+   else do+    let sz_i = fromIntegral sz+    if sz_i == 0 then return (nullPtr, 0) else do+    chunk <- mallocBytes sz_i+    r <- hGetBuf handle chunk sz_i+    hClose handle+    return (chunk, r)++-- ---------------------------------------------------------------------------+-- memcpy wrappers++foreign import ccall unsafe "__hscore_memcpy_src_off"+   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())+foreign import ccall unsafe "__hscore_memcpy_src_off"+   memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())+foreign import ccall unsafe "__hscore_memcpy_dst_off"+   memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())+foreign import ccall unsafe "__hscore_memcpy_dst_off"+   memcpy_baoff_ptr :: RawBuffer -> CInt -> 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)
− GHC/IOBase.hs 
@@ -1,40 +0,0 @@-module GHC.IOBase(-    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, -    unsafePerformIO, unsafeInterleaveIO,-    unsafeDupablePerformIO, unsafeDupableInterleaveIO,-    noDuplicate,--        -- To and from from ST-    stToIO, ioToST, unsafeIOToST, unsafeSTToIO,--        -- References-    IORef(..), newIORef, readIORef, writeIORef, -    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,-    MVar(..),--        -- Handles, file descriptors,-    FilePath,  -    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, -    isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,--        -- Buffers-    -- Buffer(..), RawBuffer, BufferState(..), -    BufferList(..), BufferMode(..),-    --bufferIsWritable, bufferEmpty, bufferFull, --        -- Exceptions-    Exception(..), ArithException(..), AsyncException(..), ArrayException(..),-    stackOverflow, heapOverflow, ioException, -    IOError, IOException(..), IOErrorType(..), ioError, userError,-    ExitCode(..),-    throwIO, block, unblock, blocked, catchAny, catchException,-    evaluate,-    ErrorCall(..), AssertionFailed(..), assertError, untangle,-    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),-    blockedOnDeadMVar, blockedIndefinitely-  ) where--import "base" GHC.Base-import "base" GHC.Exception-import "base" GHC.IO-import "base" GHC.IOBase
+ GHC/IOBase.lhs view
@@ -0,0 +1,1027 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.IOBase+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.IOBase(+    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, +    unsafePerformIO, unsafeInterleaveIO,+    unsafeDupablePerformIO, unsafeDupableInterleaveIO,+    noDuplicate,++        -- To and from from ST+    stToIO, ioToST, unsafeIOToST, unsafeSTToIO,++        -- References+    IORef(..), newIORef, readIORef, writeIORef, +    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,+    MVar(..),++        -- Handles, file descriptors,+    FilePath,  +    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, +    isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,++        -- Buffers+    Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),+    bufferIsWritable, bufferEmpty, bufferFull, ++        -- Exceptions+    Exception(..), ArithException(..), AsyncException(..), ArrayException(..),+    stackOverflow, heapOverflow, ioException, +    IOError, IOException(..), IOErrorType(..), ioError, userError,+    ExitCode(..),+    throwIO, block, unblock, blocked, catchAny, catchException,+    evaluate,+    ErrorCall(..), AssertionFailed(..), assertError, untangle,+    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),+    blockedOnDeadMVar, blockedIndefinitely+  ) where++import GHC.ST+import GHC.Arr  -- to derive Ix class+import GHC.Enum -- to derive Enum class+import GHC.STRef+import GHC.Base+--  import GHC.Num      -- To get fromInteger etc, needed because of -XNoImplicitPrelude+import Data.Maybe  ( Maybe(..) )+import GHC.Show+import GHC.List+import GHC.Read+import Foreign.C.Types (CInt)+import GHC.Exception++#ifndef __HADDOCK__+import {-# SOURCE #-} Data.Typeable     ( Typeable )+#endif++-- ---------------------------------------------------------------------------+-- The IO Monad++{-+The IO Monad is just an instance of the ST monad, where the state 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 PrimOp.lhs++RTS       - forceIO (StgMiscClosures.hc)+          - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast +            (Exceptions.hc)+          - raiseAsync (Schedule.c)++Prelude   - GHC.IOBase.lhs, and several other places including+            GHC.Exception.lhs.++Libraries - parts of hslibs/lang.++--SDM+-}++{-|+A value of type @'IO' a@ is a computation which, when performed,+does some I\/O before returning a value of type @a@.  ++There is really only one way to \"perform\" an I\/O action: bind it to+@Main.main@ in your program.  When your program is run, the I\/O will+be performed.  It isn't possible to perform I\/O from an arbitrary+function, unless that function is itself in the 'IO' monad and called+at some point, directly or indirectly, from @Main.main@.++'IO' is a monad, so 'IO' actions can be combined using either the do-notation+or the '>>' and '>>=' operations from the 'Monad' class.+-}+newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))++unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))+unIO (IO a) = a++instance  Functor IO where+   fmap f x = x >>= (return . f)++instance  Monad IO  where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    m >> k      =  m >>= \ _ -> k+    return x    = returnIO x++    m >>= k     = bindIO m k+    fail s      = failIO s++failIO :: String -> IO a+failIO s = ioError (userError s)++liftIO :: IO a -> State# RealWorld -> STret RealWorld a+liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r++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+  )++returnIO :: a -> IO a+returnIO x = IO (\ s -> (# s, x #))++-- ---------------------------------------------------------------------------+-- Coercions between IO and ST++-- | A monad transformer embedding strict state transformers 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 m) = IO m++ioToST        :: IO a -> ST RealWorld a+ioToST (IO m) = (ST m)++-- This relies on IO and ST having the same representation modulo the+-- constraint on the type of the state+--+unsafeIOToST        :: IO a -> ST s a+unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s++unsafeSTToIO :: ST s a -> IO a+unsafeSTToIO (ST m) = IO (unsafeCoerce# m)++-- ---------------------------------------------------------------------------+-- Unsafe IO operations++{-|+This is the \"back door\" into the 'IO' monad, allowing+'IO' computation to be performed at any time.  For+this to be safe, the 'IO' computation should be+free of side effects and independent of its environment.++If the I\/O computation wrapped in 'unsafePerformIO'+performs side effects, then the relative order in which those side+effects take place (relative to the main I\/O trunk, or other calls to+'unsafePerformIO') is indeterminate.  You have to be careful when +writing and compiling modules that use 'unsafePerformIO':++  * 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, 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 slightly more efficient,+because it omits the check that the IO is only being performed by a+single thread.  Hence, when you write '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.+-}+{-# NOINLINE unsafeDupablePerformIO #-}+unsafeDupablePerformIO  :: IO a -> a+unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)++-- Why do we NOINLINE unsafeDupablePerformIO?  See the comment with+-- GHC.ST.runST.  Essentially the issue is that the IO computation+-- inside unsafePerformIO must be atomic: it must either all run, or+-- not at all.  If we let the compiler see the application of the IO+-- to realWorld#, it might float out part of the IO.++-- Why is there a call to 'lazy' in unsafeDupablePerformIO?+-- If we don't have it, the demand analyser discovers the following strictness+-- for unsafeDupablePerformIO:  C(U(AV))+-- But then consider+--      unsafeDupablePerformIO (\s -> let r = f x in +--                             case writeIORef v r s of (# s1, _ #) ->+--                             (# s1, r #)+-- The strictness analyser will find that the binding for r is strict,+-- (becuase of uPIO's strictness sig), and so it'll evaluate it before +-- doing the writeIORef.  This actually makes tests/lib/should_run/memo002+-- get a deadlock!  +--+-- Solution: don't expose the strictness of unsafeDupablePerformIO,+--           by hiding it with 'lazy'++{-|+'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.+When passed a value of type @IO a@, the 'IO' will only be performed+when the value of the @a@ is demanded.  This is used to implement lazy+file reading, see 'System.IO.hGetContents'.+-}+{-# INLINE unsafeInterleaveIO #-}+unsafeInterleaveIO :: IO a -> IO a+unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)++-- We believe that INLINE on unsafeInterleaveIO is safe, because the+-- state from this IO thread is passed explicitly to the interleaved+-- IO, so it cannot be floated out and shared.++{-# INLINE unsafeDupableInterleaveIO #-}+unsafeDupableInterleaveIO :: IO a -> IO a+unsafeDupableInterleaveIO (IO m)+  = IO ( \ s -> let+                   r = case m s of (# _, res #) -> res+                in+                (# s, r #))++{-| +Ensures that the suspensions under evaluation by the current thread+are unique; that is, the current thread is not evaluating anything+that is also under evaluation by another thread that has also executed+'noDuplicate'.++This operation is used in the definition of 'unsafePerformIO' to+prevent the IO action from being executed multiple times, which is usually+undesirable.+-}+noDuplicate :: IO ()+noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)++-- ---------------------------------------------------------------------------+-- Handle type++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 a box, which may be empty or full.+-}++-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module+instance Eq (MVar a) where+        (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#++--  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.+--+-- 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 explicit+-- 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.++data Handle +  = FileHandle                          -- A normal handle to a file+        FilePath                        -- the file (invariant)+        !(MVar Handle__)++  | DuplexHandle                        -- A handle to a read/write stream+        FilePath                        -- file for a FIFO, otherwise some+                                        --   descriptive string.+        !(MVar Handle__)                -- The read side+        !(MVar Handle__)                -- The write side++-- NOTES:+--    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be+--      seekable.++instance Eq Handle where+ (FileHandle _ h1)     == (FileHandle _ h2)     = h1 == h2+ (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2+ _ == _ = False ++type FD = CInt++data Handle__+  = Handle__ {+      haFD          :: !FD,                  -- file descriptor+      haType        :: HandleType,           -- type (read/write/append etc.)+      haIsBin       :: Bool,                 -- binary mode?+      haIsStream    :: Bool,                 -- Windows : is this a socket?+                                             -- Unix    : is O_NONBLOCK set?+      haBufferMode  :: BufferMode,           -- buffer contains read/write data?+      haBuffer      :: !(IORef Buffer),      -- the current buffer+      haBuffers     :: !(IORef BufferList),  -- spare buffers+      haOtherSide   :: Maybe (MVar Handle__) -- ptr to the write side of a +                                             -- duplex handle.+    }++-- ---------------------------------------------------------------------------+-- Buffers++-- The buffer is represented by a mutable variable containing a+-- record, where the record contains the raw buffer and the start/end+-- points of the filled portion.  We use a mutable variable so that+-- the common operation of writing (or reading) some data from (to)+-- the buffer doesn't need to modify, and hence copy, the handle+-- itself, it just updates the buffer.  ++-- There will be some allocation involved in a simple hPutChar in+-- order to create the new Buffer structure (below), but this is+-- relatively small, and this only has to be done once per write+-- operation.++-- The buffer contains its size - we could also get the size by+-- calling sizeOfMutableByteArray# on the raw buffer, but that tends+-- to be rounded up to the nearest Word.++type RawBuffer = MutableByteArray# RealWorld++-- INVARIANTS on a Buffer:+--+--   * 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).+--   * r <= w+--   * if r == w, then r == 0 && w == 0+--   * if state == WriteBuffer, then r == 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.++data Buffer +  = Buffer {+        bufBuf   :: RawBuffer,+        bufRPtr  :: !Int,+        bufWPtr  :: !Int,+        bufSize  :: !Int,+        bufState :: BufferState+  }++data BufferState = ReadBuffer | WriteBuffer deriving (Eq)++-- 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 +  = BufferListNil +  | BufferListCons RawBuffer BufferList+++bufferIsWritable :: Buffer -> Bool+bufferIsWritable Buffer{ bufState=WriteBuffer } = True+bufferIsWritable _other = False++bufferEmpty :: Buffer -> Bool+bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w++-- only makes sense for a write buffer+bufferFull :: Buffer -> Bool+bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b++--  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++-- | 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++-- ---------------------------------------------------------------------------+-- 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, Ord, Read, Show)++-- ---------------------------------------------------------------------------+-- IORefs++-- |A mutable variable in the 'IO' monad+newtype IORef a = IORef (STRef RealWorld a)++-- explicit instance because Haddock can't figure out a derived one+instance Eq (IORef a) where+  IORef x == IORef y = x == y++-- |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)++-- ---------------------------------------------------------------------------+-- | 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)++-- explicit instance because Haddock can't figure out a derived one+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  :: Ix i => IOArray i e -> Int -> IO e+{-# INLINE unsafeReadIOArray #-}+unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i)++-- | Write a new value into an 'IOArray'+unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO ()+{-# 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)+++-- ---------------------------------------------------------------------------+-- 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.++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"++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 "}"++-- ------------------------------------------------------------------------+-- Exception datatypes and operations++data BlockedOnDeadMVar = BlockedOnDeadMVar+    deriving Typeable++instance Exception BlockedOnDeadMVar++instance Show BlockedOnDeadMVar where+    showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"++blockedOnDeadMVar :: SomeException -- for the RTS+blockedOnDeadMVar = toException BlockedOnDeadMVar++-----++data BlockedIndefinitely = BlockedIndefinitely+    deriving Typeable++instance Exception BlockedIndefinitely++instance Show BlockedIndefinitely where+    showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"++blockedIndefinitely :: SomeException -- for the RTS+blockedIndefinitely = toException BlockedIndefinitely++-----++data Deadlock = Deadlock+    deriving Typeable++instance Exception Deadlock++instance Show Deadlock where+    showsPrec _ Deadlock = showString "<<deadlock>>"++-----++data AssertionFailed = AssertionFailed String+    deriving Typeable++instance Exception AssertionFailed++instance Show AssertionFailed where+    showsPrec _ (AssertionFailed err) = showString err++-----++-- |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 does not throw 'HeapOverflow' exceptions.+  | 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, Ord, Typeable)++instance Exception AsyncException++-- | 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, Ord, Typeable)++instance Exception ArrayException++stackOverflow, heapOverflow :: SomeException -- for the RTS+stackOverflow = toException StackOverflow+heapOverflow  = toException HeapOverflow++instance Show AsyncException where+  showsPrec _ StackOverflow   = showString "stack overflow"+  showsPrec _ HeapOverflow    = showString "heap overflow"+  showsPrec _ ThreadKilled    = showString "thread killed"+  showsPrec _ UserInterrupt   = showString "user interrupt"++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 ExitCode type++-- We need it here because it is used in ExitException in the+-- Exception datatype (above).++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, Typeable)++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 98 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 98, 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_filename :: Maybe FilePath  -- filename the error is related to.+   }+    deriving Typeable++instance Exception IOException++instance Eq IOException where+  (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = +    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2++-- | An abstract type that contains a value for each variant of 'IOError'.+data IOErrorType+  -- Haskell 98:+  = AlreadyExists+  | NoSuchThing+  | ResourceBusy+  | ResourceExhausted+  | EOF+  | IllegalOperation+  | PermissionDenied+  | UserError+  -- GHC only:+  | UnsatisfiedConstraints+  | SystemError+  | ProtocolError+  | OtherError+  | InvalidArgument+  | InappropriateType+  | HardwareFault+  | UnsupportedOperation+  | TimeExpired+  | ResourceVanished+  | Interrupted++instance Eq IOErrorType where+   x == y = getTag x ==# getTag y+ +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 -> "unsatisified 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++-- ---------------------------------------------------------------------------+-- Showing IOErrors++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 ")")++-- -----------------------------------------------------------------------------+-- IOMode type++data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode+                    deriving (Eq, Ord, Ix, Enum, Read, Show)+\end{code}++%*********************************************************+%*                                                      *+\subsection{Primitive catch and throwIO}+%*                                                      *+%*********************************************************++catchException 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 catchException below).++\begin{code}+catchException :: Exception e => IO a -> (e -> IO a) -> IO a+catchException (IO io) handler = IO $ catch# io handler'+    where handler' e = case fromException e of+                       Just e' -> unIO (handler e')+                       Nothing -> raise# e++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)++-- | A variant of 'throw' that can 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))+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Controlling asynchronous exception delivery}+%*                                                      *+%*********************************************************++\begin{code}+-- | 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 enabled 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++-- | 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++block (IO io) = IO $ blockAsyncExceptions# io+unblock (IO io) = IO $ unblockAsyncExceptions# io++-- | returns True if asynchronous exceptions are blocked in the+-- current thread.+blocked :: IO Bool+blocked = IO $ \s -> case asyncExceptionsBlocked# s of+                        (# s', i #) -> (# s', i /=# 0# #)+\end{code}++\begin{code}+-- | Forces its argument to be evaluated when the resultant 'IO' action+-- is executed.  It can be used to order evaluation with respect to+-- other 'IO' operations; its semantics are given by+--+-- >   evaluate x `seq` y    ==>  y+-- >   evaluate x `catch` f  ==>  (return $! x) `catch` f+-- >   evaluate x >>= f      ==>  (return $! x) >>= f+--+-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the+-- same as @(return $! x)@.  A correct definition is+--+-- >   evaluate x = (return $! x) >>= return+--+evaluate :: a -> IO a+evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)+        -- NB. can't write+        --      a `seq` (# s, a #)+        -- because we can't have an unboxed tuple as a function argument+\end{code}++\begin{code}+assertError :: Addr# -> Bool -> a -> a+assertError str predicate v+  | predicate = v+  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))++{-+(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 /= '|'+\end{code}+
GHC/Int.hs view
@@ -1,2 +1,807 @@-module GHC.Int (module X___) where-import "base" GHC.Int as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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"++-- #hide+module GHC.Int (+    Int8(..), Int16(..), Int32(..), Int64(..),+    uncheckedIShiftL64#, uncheckedIShiftRA64#+    ) where++import Data.Bits++#if WORD_SIZE_IN_BITS < 32+import GHC.IntWord32+#endif+#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif++import GHC.Base+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Read+import GHC.Arr+import GHC.Word hiding (uncheckedShiftL64#, uncheckedShiftRL64#)+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 Int8 = I8# Int# deriving (Eq, Ord)+-- ^ 8-bit signed integer type++instance Show Int8 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int8 where+    (I8# x#) + (I8# y#)    = I8# (narrow8Int# (x# +# y#))+    (I8# x#) - (I8# y#)    = I8# (narrow8Int# (x# -# y#))+    (I8# x#) * (I8# y#)    = I8# (narrow8Int# (x# *# y#))+    negate (I8# x#)        = I8# (narrow8Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I8# (narrow8Int# (toInt# i))++instance Real Int8 where+    toRational x = toInteger x % 1++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# i#+        | otherwise     = toEnumError "Int8" i (minBound::Int8, maxBound::Int8)+    fromEnum (I8# x#)   = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int8 where+    quot    x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `quotInt#` y#))+    rem     x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `remInt#` y#))+    div     x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `divInt#` y#))+    mod     x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I8# (narrow8Int# (x# `modInt#` y#))+    quotRem x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I8# (narrow8Int# (x# `quotInt#` y#)),+                                       I8# (narrow8Int# (x# `remInt#` y#)))+    divMod  x@(I8# x#) y@(I8# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I8# (narrow8Int# (x# `divInt#` y#)),+                                       I8# (narrow8Int# (x# `modInt#` y#)))+    toInteger (I8# x#)               = smallInteger x#++instance Bounded Int8 where+    minBound = -0x80+    maxBound =  0x7F++instance Ix Int8 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n++instance Read Int8 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int8 where+    {-# INLINE shift #-}++    (I8# x#) .&.   (I8# y#)   = I8# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I8# x#) .|.   (I8# y#)   = I8# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I8# x#) `xor` (I8# y#)   = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I8# x#)       = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I8# x#) `shift` (I# i#)+        | i# >=# 0#           = I8# (narrow8Int# (x# `iShiftL#` i#))+        | otherwise           = I8# (x# `iShiftRA#` negateInt# i#)+    (I8# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I8# x#+        | otherwise+        = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                       (x'# `uncheckedShiftRL#` (8# -# i'#)))))+        where+        x'# = narrow8Word# (int2Word# x#)+        i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)+    bitSize  _                = 8+    isSigned _                = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8+"fromIntegral/a->Int8"    fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#)+"fromIntegral/Int8->a"    fromIntegral = \(I8# x#) -> fromIntegral (I# x#)+  #-}++------------------------------------------------------------------------+-- 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 Int16 = I16# Int# deriving (Eq, Ord)+-- ^ 16-bit signed integer type++instance Show Int16 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int16 where+    (I16# x#) + (I16# y#)  = I16# (narrow16Int# (x# +# y#))+    (I16# x#) - (I16# y#)  = I16# (narrow16Int# (x# -# y#))+    (I16# x#) * (I16# y#)  = I16# (narrow16Int# (x# *# y#))+    negate (I16# x#)       = I16# (narrow16Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I16# (narrow16Int# (toInt# i))++instance Real Int16 where+    toRational x = toInteger x % 1++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# i#+        | otherwise     = toEnumError "Int16" i (minBound::Int16, maxBound::Int16)+    fromEnum (I16# x#)  = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int16 where+    quot    x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `quotInt#` y#))+    rem     x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `remInt#` y#))+    div     x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `divInt#` y#))+    mod     x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I16# (narrow16Int# (x# `modInt#` y#))+    quotRem x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I16# (narrow16Int# (x# `quotInt#` y#)),+                                        I16# (narrow16Int# (x# `remInt#` y#)))+    divMod  x@(I16# x#) y@(I16# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I16# (narrow16Int# (x# `divInt#` y#)),+                                        I16# (narrow16Int# (x# `modInt#` y#)))+    toInteger (I16# x#)              = smallInteger x#++instance Bounded Int16 where+    minBound = -0x8000+    maxBound =  0x7FFF++instance Ix Int16 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n++instance Read Int16 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int16 where+    {-# INLINE shift #-}++    (I16# x#) .&.   (I16# y#)  = I16# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I16# x#) .|.   (I16# y#)  = I16# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I16# x#) `xor` (I16# y#)  = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I16# x#)       = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I16# x#) `shift` (I# i#)+        | i# >=# 0#            = I16# (narrow16Int# (x# `iShiftL#` i#))+        | otherwise            = I16# (x# `iShiftRA#` negateInt# i#)+    (I16# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I16# x#+        | otherwise+        = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                         (x'# `uncheckedShiftRL#` (16# -# i'#)))))+        where+        x'# = narrow16Word# (int2Word# x#)+        i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)+    bitSize  _                 = 16+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Int16"  fromIntegral = \(W8# x#) -> I16# (word2Int# x#)+"fromIntegral/Int8->Int16"   fromIntegral = \(I8# x#) -> I16# x#+"fromIntegral/Int16->Int16"  fromIntegral = id :: Int16 -> Int16+"fromIntegral/a->Int16"      fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#)+"fromIntegral/Int16->a"      fromIntegral = \(I16# x#) -> fromIntegral (I# x#)+  #-}++------------------------------------------------------------------------+-- type Int32+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 32++data Int32 = I32# Int32#+-- ^ 32-bit signed integer type++instance Eq Int32 where+    (I32# x#) == (I32# y#) = x# `eqInt32#` y#+    (I32# x#) /= (I32# y#) = x# `neInt32#` y#++instance Ord Int32 where+    (I32# x#) <  (I32# y#) = x# `ltInt32#` y#+    (I32# x#) <= (I32# y#) = x# `leInt32#` y#+    (I32# x#) >  (I32# y#) = x# `gtInt32#` y#+    (I32# x#) >= (I32# y#) = x# `geInt32#` y#++instance Show Int32 where+    showsPrec p x = showsPrec p (toInteger x)++instance Num Int32 where+    (I32# x#) + (I32# y#)  = I32# (x# `plusInt32#`  y#)+    (I32# x#) - (I32# y#)  = I32# (x# `minusInt32#` y#)+    (I32# x#) * (I32# y#)  = I32# (x# `timesInt32#` y#)+    negate (I32# x#)       = I32# (negateInt32# x#)+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger (S# i#)    = I32# (intToInt32# i#)+    fromInteger (J# s# d#) = I32# (integerToInt32# s# d#)++instance Enum Int32 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int32"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int32"+    toEnum (I# i#)      = I32# (intToInt32# i#)+    fromEnum x@(I32# x#)+        | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)+                        = I# (int32ToInt# x#)+        | otherwise     = fromEnumError "Int32" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Int32 where+    quot    x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (x# `quotInt32#` y#)+    rem     x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = I32# (x# `remInt32#` y#)+    div     x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = I32# (x# `divInt32#` y#)+    mod     x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = I32# (x# `modInt32#` y#)+    quotRem x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = (I32# (x# `quotInt32#` y#),+                                     I32# (x# `remInt32#` y#))+    divMod  x@(I32# x#) y@(I32# y#)+        | y == 0                  = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise               = (I32# (x# `divInt32#` y#),+                                     I32# (x# `modInt32#` y#))+    toInteger x@(I32# x#)+	| x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)+                                  = smallInteger (int32ToInt# x#)+        | otherwise               = case int32ToInteger# x# of (# s, d #) -> J# s d++divInt32#, modInt32# :: Int32# -> Int32# -> Int32#+x# `divInt32#` y#+    | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#)+        = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y#+    | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)+        = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y#+    | otherwise                = x# `quotInt32#` y#+x# `modInt32#` y#+    | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) ||+      (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#)+        = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0#+    | otherwise = r#+    where+    r# = x# `remInt32#` y#++instance Read Int32 where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]++instance Bits Int32 where+    {-# INLINE shift #-}++    (I32# x#) .&.   (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#))+    (I32# x#) .|.   (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `or32#`  int32ToWord32# y#))+    (I32# x#) `xor` (I32# y#)  = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#))+    complement (I32# x#)       = I32# (word32ToInt32# (not32# (int32ToWord32# x#)))+    (I32# x#) `shift` (I# i#)+        | i# >=# 0#            = I32# (x# `iShiftL32#` i#)+        | otherwise            = I32# (x# `iShiftRA32#` negateInt# i#)+    (I32# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I32# x#+        | otherwise+        = I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#`+                                (x'# `shiftRL32#` (32# -# i'#))))+        where+        x'# = int32ToWord32# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                 = 32+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int->Int32"    fromIntegral = \(I#   x#) -> I32# (intToInt32# x#)+"fromIntegral/Word->Int32"   fromIntegral = \(W#   x#) -> I32# (word32ToInt32# (wordToWord32# x#))+"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#)+"fromIntegral/Int32->Int"    fromIntegral = \(I32# x#) -> I#   (int32ToInt# x#)+"fromIntegral/Int32->Word"   fromIntegral = \(I32# x#) -> W#   (int2Word# (int32ToInt# x#))+"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#)+"fromIntegral/Int32->Int32"  fromIntegral = id :: Int32 -> Int32+  #-}++#else ++-- Int32 is represented in the same way as Int.+#if WORD_SIZE_IN_BITS > 32+-- Operations may assume and must ensure that it holds only values+-- from its logical range.+#endif++data Int32 = I32# Int# deriving (Eq, Ord)+-- ^ 32-bit signed integer type++instance Show Int32 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int32 where+    (I32# x#) + (I32# y#)  = I32# (narrow32Int# (x# +# y#))+    (I32# x#) - (I32# y#)  = I32# (narrow32Int# (x# -# y#))+    (I32# x#) * (I32# y#)  = I32# (narrow32Int# (x# *# y#))+    negate (I32# x#)       = I32# (narrow32Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I32# (narrow32Int# (toInt# i))++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# i#+#else+    toEnum i@(I# i#)+        | i >= fromIntegral (minBound::Int32) && i <= fromIntegral (maxBound::Int32)+                        = I32# i#+        | otherwise     = toEnumError "Int32" i (minBound::Int32, maxBound::Int32)+#endif+    fromEnum (I32# x#)  = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int32 where+    quot    x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `quotInt#` y#))+    rem     x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `remInt#` y#))+    div     x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `divInt#` y#))+    mod     x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I32# (narrow32Int# (x# `modInt#` y#))+    quotRem x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I32# (narrow32Int# (x# `quotInt#` y#)),+                                     I32# (narrow32Int# (x# `remInt#` y#)))+    divMod  x@(I32# x#) y@(I32# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I32# (narrow32Int# (x# `divInt#` y#)),+                                     I32# (narrow32Int# (x# `modInt#` y#)))+    toInteger (I32# x#)              = smallInteger x#++instance Read Int32 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int32 where+    {-# INLINE shift #-}++    (I32# x#) .&.   (I32# y#)  = I32# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I32# x#) .|.   (I32# y#)  = I32# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I32# x#) `xor` (I32# y#)  = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I32# x#)       = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I32# x#) `shift` (I# i#)+        | i# >=# 0#            = I32# (narrow32Int# (x# `iShiftL#` i#))+        | otherwise            = I32# (x# `iShiftRA#` negateInt# i#)+    (I32# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I32# x#+        | otherwise+        = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                         (x'# `uncheckedShiftRL#` (32# -# i'#)))))+        where+        x'# = narrow32Word# (int2Word# x#)+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                 = 32+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Int32"  fromIntegral = \(W8# x#) -> I32# (word2Int# x#)+"fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#)+"fromIntegral/Int8->Int32"   fromIntegral = \(I8# x#) -> I32# x#+"fromIntegral/Int16->Int32"  fromIntegral = \(I16# x#) -> I32# x#+"fromIntegral/Int32->Int32"  fromIntegral = id :: Int32 -> Int32+"fromIntegral/a->Int32"      fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#)+"fromIntegral/Int32->a"      fromIntegral = \(I32# x#) -> fromIntegral (I# x#)+  #-}++#endif ++instance Real Int32 where+    toRational x = toInteger x % 1++instance Bounded Int32 where+    minBound = -0x80000000+    maxBound =  0x7FFFFFFF++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 Int64 = I64# Int64#+-- ^ 64-bit signed integer type++instance Eq Int64 where+    (I64# x#) == (I64# y#) = x# `eqInt64#` y#+    (I64# x#) /= (I64# y#) = x# `neInt64#` y#++instance Ord Int64 where+    (I64# x#) <  (I64# y#) = x# `ltInt64#` y#+    (I64# x#) <= (I64# y#) = x# `leInt64#` y#+    (I64# x#) >  (I64# y#) = x# `gtInt64#` y#+    (I64# x#) >= (I64# y#) = x# `geInt64#` y#++instance Show Int64 where+    showsPrec p x = showsPrec p (toInteger x)++instance Num Int64 where+    (I64# x#) + (I64# y#)  = I64# (x# `plusInt64#`  y#)+    (I64# x#) - (I64# y#)  = I64# (x# `minusInt64#` 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)++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+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Int64 where+    quot    x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `quotInt64#` y#)+    rem     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `remInt64#` y#)+    div     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `divInt64#` y#)+    mod     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `modInt64#` y#)+    quotRem x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `quotInt64#` y#),+                                        I64# (x# `remInt64#` y#))+    divMod  x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `divInt64#` y#),+                                        I64# (x# `modInt64#` y#))+    toInteger (I64# x)               = int64ToInteger x+++divInt64#, modInt64# :: Int64# -> Int64# -> Int64#+x# `divInt64#` y#+    | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#)+        = ((x# `minusInt64#` y#) `minusInt64#` intToInt64# 1#) `quotInt64#` y#+    | (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#)+        = ((x# `minusInt64#` y#) `plusInt64#` intToInt64# 1#) `quotInt64#` y#+    | otherwise                = x# `quotInt64#` y#+x# `modInt64#` y#+    | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) ||+      (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#)+        = if r# `neInt64#` intToInt64# 0# then r# `plusInt64#` y# else intToInt64# 0#+    | otherwise = r#+    where+    r# = x# `remInt64#` y#++instance Read Int64 where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]++instance Bits Int64 where+    {-# INLINE shift #-}++    (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#)+        | i# >=# 0#            = I64# (x# `iShiftL64#` i#)+        | otherwise            = I64# (x# `iShiftRA64#` negateInt# i#)+    (I64# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I64# x#+        | otherwise+        = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#`+                                (x'# `uncheckedShiftRL64#` (64# -# i'#))))+        where+        x'# = int64ToWord64# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                 = 64+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)+++-- 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  | b >=# 64# = intToInt64# 0#+		  | otherwise = a `uncheckedIShiftL64#` b++a `iShiftRA64#` b | b >=# 64# = if a `ltInt64#` (intToInt64# 0#) +					then intToInt64# (-1#) +					else intToInt64# 0#+		  | otherwise = a `uncheckedIShiftRA64#` b++{-# RULES+"fromIntegral/Int->Int64"    fromIntegral = \(I#   x#) -> I64# (intToInt64# x#)+"fromIntegral/Word->Int64"   fromIntegral = \(W#   x#) -> I64# (word64ToInt64# (wordToWord64# x#))+"fromIntegral/Word64->Int64" fromIntegral = \(W64# x#) -> I64# (word64ToInt64# x#)+"fromIntegral/Int64->Int"    fromIntegral = \(I64# x#) -> I#   (int64ToInt# x#)+"fromIntegral/Int64->Word"   fromIntegral = \(I64# x#) -> W#   (int2Word# (int64ToInt# x#))+"fromIntegral/Int64->Word64" fromIntegral = \(I64# x#) -> W64# (int64ToWord64# x#)+"fromIntegral/Int64->Int64"  fromIntegral = id :: Int64 -> Int64+  #-}++#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 Int64 = I64# Int# deriving (Eq, Ord)+-- ^ 64-bit signed integer type++instance Show Int64 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++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# (toInt# i)++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#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int64 where+    quot    x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `quotInt#` y#)+    rem     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `remInt#` y#)+    div     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `divInt#` y#)+    mod     x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I64# (x# `modInt#` y#)+    quotRem x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#))+    divMod  x@(I64# x#) y@(I64# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#))+    toInteger (I64# x#)              = smallInteger x#++instance Read Int64 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int64 where+    {-# INLINE shift #-}++    (I64# x#) .&.   (I64# y#)  = I64# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I64# x#) .|.   (I64# y#)  = I64# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I64# x#) `xor` (I64# y#)  = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I64# x#)       = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))+    (I64# x#) `shift` (I# i#)+        | i# >=# 0#            = I64# (x# `iShiftL#` i#)+        | otherwise            = I64# (x# `iShiftRA#` negateInt# i#)+    (I64# x#) `rotate` (I# i#)+        | i'# ==# 0# +        = I64# x#+        | otherwise+        = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                           (x'# `uncheckedShiftRL#` (64# -# i'#))))+        where+        x'# = int2Word# x#+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                 = 64+    isSigned _                 = True++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x#+"fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#)+  #-}++uncheckedIShiftL64# :: Int# -> Int# -> Int#+uncheckedIShiftL64#  = uncheckedIShiftL#++uncheckedIShiftRA64# :: Int# -> Int# -> Int#+uncheckedIShiftRA64# = uncheckedIShiftRA#+#endif++instance Real Int64 where+    toRational x = toInteger x % 1++instance Bounded Int64 where+    minBound = -0x8000000000000000+    maxBound =  0x7FFFFFFFFFFFFFFF++instance Ix Int64 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n
− GHC/List.hs 
@@ -1,2 +0,0 @@-module GHC.List (module X___) where-import "base" GHC.List as X___
+ GHC/List.lhs view
@@ -0,0 +1,733 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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+--+-----------------------------------------------------------------------------++-- #hide+module GHC.List (+   -- [] (..),          -- Not Haskell 98; built in syntax++   map, (++), filter, concat,+   head, last, tail, init, null, length, (!!),+   foldl, scanl, scanl1, foldr, foldr1, scanr, scanr1,+   iterate, repeat, replicate, cycle,+   take, drop, splitAt, takeWhile, dropWhile, span, break,+   reverse, and, or,+   any, all, elem, notElem, lookup,+   concatMap,+   zip, zip3, zipWith, zipWith3, unzip, unzip3,+   errorEmptyList,++#ifndef USE_REPORT_PRELUDE+   -- non-standard, but hidden when creating the Prelude+   -- export list.+   takeUInt_append+#endif++ ) where++import Data.Maybe+import GHC.Base++infixl 9  !!+infix  4 `elem`, `notElem`+\end{code}++%*********************************************************+%*                                                      *+\subsection{List-manipulation functions}+%*                                                      *+%*********************************************************++\begin{code}+-- | Extract the first element of a list, which must be non-empty.+head                    :: [a] -> a+head (x:_)              =  x+head []                 =  badHead++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)+ #-}++-- | Extract the elements after the head of a list, which must be non-empty.+tail                    :: [a] -> [a]+tail (_:xs)             =  xs+tail []                 =  errorEmptyList "tail"++-- | Extract the last element of a list, which must be finite and non-empty.+last                    :: [a] -> a+#ifdef USE_REPORT_PRELUDE+last [x]                =  x+last (_:xs)             =  last xs+last []                 =  errorEmptyList "last"+#else+-- eliminate repeated cases+last []                 =  errorEmptyList "last"+last (x:xs)             =  last' x xs+  where last' y []     = y+        last' _ (y:ys) = last' y ys+#endif++-- | Return all the elements of a list except the last one.+-- The list must be finite and non-empty.+init                    :: [a] -> [a]+#ifdef 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++-- | Test whether a list is empty.+null                    :: [a] -> Bool+null []                 =  True+null (_:_)              =  False++-- | '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                  :: [a] -> Int+length l                =  len l 0#+  where+    len :: [a] -> Int# -> Int+    len []     a# = I# a#+    len (_:xs) a# = len xs (a# +# 1#)++-- | '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 :: (a -> Bool) -> [a] -> [a]+filter _pred []    = []+filter pred (x:xs)+  | pred x         = x : filter pred xs+  | otherwise      = filter pred xs++{-# NOINLINE [0] filterFB #-}+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.++-- We write foldl as a non-recursive thing, so that it+-- can be inlined, and then (often) strictness-analysed,+-- and hence the classic space leak on foldl (+) 0 xs++foldl        :: (a -> b -> a) -> a -> [b] -> a+foldl f z0 xs0 = lgo z0 xs0+             where+                lgo z []     =  z+                lgo z (x:xs) = lgo (f z x) xs++-- | '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                   :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q ls            =  q : (case ls of+                                []   -> []+                                x:xs -> scanl f (f q x) xs)++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:+--+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]++scanl1                  :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)         =  scanl f x xs+scanl1 _ []             =  []++-- 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.++foldr1                  :: (a -> a -> a) -> [a] -> a+foldr1 _ [x]            =  x+foldr1 f (x:xs)         =  f x (foldr1 f xs)+foldr1 _ []             =  errorEmptyList "foldr1"++-- | 'scanr' is the right-to-left dual of 'scanl'.+-- Note that+--+-- > head (scanr f z xs) == foldr f z xs.++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 ++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.++scanr1                  :: (a -> a -> a) -> [a] -> [a]+scanr1 _ []             =  []+scanr1 _ [x]            =  [x]+scanr1 f (x:xs)         =  f x q : qs+                           where qs@(q:_) = scanr1 f xs ++-- | 'iterate' @f x@ returns an infinite list of repeated applications+-- of @f@ to @x@:+--+-- > iterate f x == [x, f x, f (f x), ...]++iterate :: (a -> a) -> a -> [a]+iterate f x =  x : iterate f (f x)++iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b+iterateFB c f x = x `c` iterateFB c f (f x)+++{-# RULES+"iterate"    [~1] forall f x.   iterate f x = build (\c _n -> iterateFB c f x)+"iterateFB"  [1]                iterateFB (:) = iterate+ #-}+++-- | 'repeat' @x@ is an infinite list, with @x@ the value of every element.+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+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.+{-# 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                   :: [a] -> [a]+cycle []                = error "Prelude.cycle: empty list"+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] == []+--++takeWhile               :: (a -> Bool) -> [a] -> [a]+takeWhile _ []          =  []+takeWhile p (x:xs) +            | p x       =  x : takeWhile p xs+            | otherwise =  []++-- | '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]++-- | '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]++-- | '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)@.+-- '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])++#ifdef USE_REPORT_PRELUDE+take n _      | n <= 0 =  []+take _ []              =  []+take n (x:xs)          =  x : take (n-1) xs++drop n xs     | n <= 0 =  xs+drop _ []              =  []+drop n (_:xs)          =  drop (n-1) xs++splitAt n xs           =  (take n xs, drop n xs)++#else /* hack away */+{-# RULES+"take"     [~1] forall n xs . take n xs = takeFoldr n xs +"takeList"  [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs+ #-}++{-# INLINE takeFoldr #-}+takeFoldr :: Int -> [a] -> [a]+takeFoldr (I# n#) xs+  = build (\c nil -> if n# <=# 0# then nil else+                     foldr (takeFB c nil) (takeConst nil) xs n#)++{-# NOINLINE [0] takeConst #-}+-- just a version of const that doesn't get inlined too early, so we+-- can spot it in rules.  Also we need a type sig due to the unboxed Int#.+takeConst :: a -> Int# -> a+takeConst x _ = x++{-# NOINLINE [0] takeFB #-}+takeFB :: (a -> b -> b) -> b -> a -> (Int# -> b) -> Int# -> b+takeFB c n x xs m | m <=# 1#  = x `c` n+                  | otherwise = x `c` xs (m -# 1#)++{-# INLINE [0] take #-}+take (I# n#) xs = takeUInt n# xs++-- The general code for take, below, checks n <= maxInt+-- No need to check for maxInt overflow when specialised+-- at type Int or Int# since the Int must be <= maxInt++takeUInt :: Int# -> [b] -> [b]+takeUInt n xs+  | n >=# 0#  =  take_unsafe_UInt n xs+  | otherwise =  []++take_unsafe_UInt :: Int# -> [b] -> [b]+take_unsafe_UInt 0#  _  = []+take_unsafe_UInt m   ls =+  case ls of+    []     -> []+    (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs++takeUInt_append :: Int# -> [b] -> [b] -> [b]+takeUInt_append n xs rs+  | n >=# 0#  =  take_unsafe_UInt_append n xs rs+  | otherwise =  []++take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b]+take_unsafe_UInt_append 0#  _ rs  = rs+take_unsafe_UInt_append m  ls rs  =+  case ls of+    []     -> rs+    (x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs++drop (I# n#) ls+  | n# <# 0#    = ls+  | otherwise   = drop# n# ls+    where+        drop# :: Int# -> [a] -> [a]+        drop# 0# xs      = xs+        drop# _  xs@[]   = xs+        drop# m# (_:xs)  = drop# (m# -# 1#) xs++splitAt (I# n#) ls+  | n# <# 0#    = ([], ls)+  | otherwise   = splitAt# n# ls+    where+        splitAt# :: Int# -> [a] -> ([a], [a])+        splitAt# 0# xs     = ([], xs)+        splitAt# _  xs@[]  = (xs, 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])+#ifdef 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                 :: [a] -> [a]+#ifdef 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                     :: [Bool] -> Bool++-- | '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                      :: [Bool] -> Bool+#ifdef USE_REPORT_PRELUDE+and                     =  foldr (&&) True+or                      =  foldr (||) False+#else+and []          =  True+and (x:xs)      =  x && and xs+or []           =  False+or (x:xs)       =  x || or xs++{-# RULES+"and/build"     forall (g::forall b.(Bool->b->b)->b->b) . +                and (build g) = g (&&) True+"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.+any                     :: (a -> Bool) -> [a] -> Bool++-- | Applied to a predicate and a list, 'all' determines if all elements+-- of the list satisfy the predicate.+all                     :: (a -> Bool) -> [a] -> Bool+#ifdef USE_REPORT_PRELUDE+any p                   =  or . map p+all p                   =  and . map p+#else+any _ []        = False+any p (x:xs)    = p x || any p xs++all _ []        =  True+all p (x:xs)    =  p x && all p xs+{-# RULES+"any/build"     forall p (g::forall b.(a->b->b)->b->b) . +                any p (build g) = g ((||) . p) False+"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@.+elem                    :: (Eq a) => a -> [a] -> Bool++-- | 'notElem' is the negation of 'elem'.+notElem                 :: (Eq a) => a -> [a] -> Bool+#ifdef USE_REPORT_PRELUDE+elem x                  =  any (== x)+notElem x               =  all (/= x)+#else+elem _ []       = False+elem x (y:ys)   = x==y || elem x ys++notElem _ []    =  True+notElem x (y:ys)=  x /= y && notElem x ys+#endif++-- | 'lookup' @key assocs@ looks up a key in an association list.+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 over a list and concatenate the results.+concatMap               :: (a -> [b]) -> [a] -> [b]+concatMap f             =  foldr ((++) . f) []++-- | Concatenate a list of lists.+concat :: [[a]] -> [a]+concat = foldr (++) []++{-# 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+ #-}++\end{code}+++\begin{code}+-- | 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] -> Int -> a+#ifdef USE_REPORT_PRELUDE+xs     !! n | n < 0 =  error "Prelude.!!: negative index"+[]     !! _         =  error "Prelude.!!: index too large"+(x:_)  !! 0         =  x+(_:xs) !! n         =  xs !! (n-1)+#else+-- HBC version (stolen), then unboxified+-- The semantics is not quite the same for error conditions+-- in the more efficient version.+--+xs !! (I# n0) | n0 <# 0#   =  error "Prelude.(!!): negative index\n"+               | otherwise =  sub xs n0+                         where+                            sub :: [a] -> Int# -> a+                            sub []     _ = error "Prelude.(!!): index too large\n"+                            sub (y:ys) n = if n ==# 0#+                                           then y+                                           else sub ys (n -# 1#)+#endif+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The zip family}+%*                                                      *+%*********************************************************++\begin{code}+foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c+foldr2 _k z []    _ys    = z+foldr2 _k z _xs   []     = z+foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys)++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_right :: (a -> b -> c -> d) -> d -> b -> ([a] -> c) -> [a] -> d+foldr2_right _k z  _y _r []     = z+foldr2_right  k _z  y  r (x:xs) = k x y (r xs)++-- foldr2 k z xs ys = foldr (foldr2_left k z)  (\_ -> z) xs ys+-- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs+{-# RULES+"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++"foldr2/right"  forall k z xs (g::forall b.(a->b->b)->b->b) . +                  foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs+ #-}+\end{code}++The foldr2/right rule isn't exactly right, because it changes+the strictness of foldr2 (and thereby zip)++E.g. main = print (null (zip nonobviousNil (build undefined)))+          where   nonobviousNil = f 3+                  f n = if n == 0 then [] else f (n-1)++I'm going to leave it though.+++Zips for larger tuples are in the List module.++\begin{code}+----------------------------------------------+-- | 'zip' takes two lists and returns a list of corresponding pairs.+-- If one input list is short, excess elements of the longer list are+-- discarded.+zip :: [a] -> [b] -> [(a,b)]+zip (a:as) (b:bs) = (a,b) : zip as bs+zip _      _      = []++{-# INLINE [0] zipFB #-}+zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d+zipFB c x y r = (x,y) `c` r++{-# RULES+"zip"      [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)+"zipList"  [1]  foldr2 (zipFB (:)) []   = zip+ #-}+\end{code}++\begin{code}+----------------------------------------------+-- | 'zip3' takes three lists and returns a list of triples, analogous to+-- 'zip'.+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 _      _      _      = []+\end{code}+++-- The zipWith family generalises the zip family by zipping with the+-- function given as the first argument, instead of a tupling function.++\begin{code}+----------------------------------------------+-- | 'zipWith' generalises 'zip' by zipping with the function given+-- as the first argument, instead of a tupling function.+-- For example, @'zipWith' (+)@ is applied to two lists to produce the+-- list of corresponding sums.+zipWith :: (a->b->c) -> [a]->[b]->[c]+zipWith f (a:as) (b:bs) = f a b : zipWith f as bs+zipWith _ _      _      = []++{-# INLINE [0] zipWithFB #-}+zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c+zipWithFB c f x y r = (x `f` y) `c` r++{-# RULES+"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+  #-}+\end{code}++\begin{code}+-- | The 'zipWith3' function takes a function which combines three+-- elements, as well as three lists and returns a list of their point-wise+-- combination, analogous to 'zipWith'.+zipWith3                :: (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith3 z (a:as) (b:bs) (c:cs)+                        =  z a b c : zipWith3 z as bs cs+zipWith3 _ _ _ _        =  []++-- | 'unzip' transforms a list of pairs into a list of first components+-- and a list of second components.+unzip    :: [(a,b)] -> ([a],[b])+{-# INLINE unzip #-}+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   :: [(a,b,c)] -> ([a],[b],[c])+{-# INLINE unzip3 #-}+unzip3   =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+                  ([],[],[])+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Error code}+%*                                                      *+%*********************************************************++Common up near identical calls to `error' to reduce the number+constant strings created when compiled:++\begin{code}+errorEmptyList :: String -> a+errorEmptyList fun =+  error (prel_list_str ++ fun ++ ": empty list")++prel_list_str :: String+prel_list_str = "Prelude."+\end{code}
− GHC/Num.hs 
@@ -1,2 +0,0 @@-module GHC.Num (module X___) where-import "base" GHC.Num as X___
+ GHC/Num.lhs view
@@ -0,0 +1,329 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++#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++-- #hide+module GHC.Num (module GHC.Num, module GHC.Integer) where++import GHC.Base+import GHC.Enum+import GHC.Show+import GHC.Integer++infixl 7  *+infixl 6  +, -++default ()              -- Double isn't available yet, +                        -- and we shouldn't be using defaults anyway+\end{code}++%*********************************************************+%*                                                      *+\subsection{Standard numeric class}+%*                                                      *+%*********************************************************++\begin{code}+-- | Basic numeric class.+--+-- Minimal complete definition: all except 'negate' or @(-)@+class  (Eq a, Show a) => Num a  where+    (+), (-), (*)       :: 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++    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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Int@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Num Int  where+    (+)    = plusInt+    (-)    = minusInt+    negate = negateInt+    (*)    = timesInt+    abs n  = if n `geInt` 0 then n else negateInt n++    signum n | n `ltInt` 0 = negateInt 1+             | n `eqInt` 0 = 0+             | otherwise   = 1++    fromInteger i = I# (toInt# i)++quotRemInt :: Int -> Int -> (Int, Int)+quotRemInt a@(I# _) b@(I# _) = (a `quotInt` b, a `remInt` b)+    -- OK, so I made it a little stricter.  Shoot me.  (WDP 94/10)++divModInt ::  Int -> Int -> (Int, Int)+divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y)+    -- Stricter.  Sorry if you don't like it.  (WDP 94/10)+\end{code}++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Eq@, @Ord@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Eq Integer  where+    (==) = eqInteger+    (/=) = neqInteger++------------------------------------------------------------------------+instance Ord Integer where+    (<=) = leInteger+    (>)  = gtInteger+    (<)  = ltInteger+    (>=) = geInteger+    compare = compareInteger+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Show@}+%*                                                      *+%*********************************************************++\begin{code}+instance Show Integer where+    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)++-- Divide an 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 `quotRemInteger` p of+        (# q, r #) ->+            if q > 0 then fromInteger q : fromInteger r : jsplitb p ns+                     else fromInteger r : jsplitb p ns+    jsplith _ [] = error "jsplith: []"++    jsplitb :: Integer -> [Integer] -> [Integer]+    jsplitb _ []     = []+    jsplitb p (n:ns) = case n `quotRemInteger` 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 `quotRemInteger` 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 [] _ = error "jprinth []"++    jprintb :: [Integer] -> String -> String+    jprintb []     cs = cs+    jprintb (n:ns) cs = case n `quotRemInteger` 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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instances for @Num@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Num Integer  where+    (+) = plusInteger+    (-) = minusInteger+    (*) = timesInteger+    negate         = negateInteger+    fromInteger x  =  x++    abs = absInteger+    signum = signumInteger+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Integer@ instance for @Enum@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Enum Integer  where+    succ x               = x + 1+    pred x               = x - 1+    toEnum (I# n)        = smallInteger n+    fromEnum n           = I# (toInt# n)++    {-# INLINE enumFrom #-}+    {-# INLINE enumFromThen #-}+    {-# INLINE enumFromTo #-}+    {-# INLINE enumFromThenTo #-}+    enumFrom x             = enumDeltaInteger  x 1+    enumFromThen x y       = enumDeltaInteger  x (y-x)+    enumFromTo x lim       = enumDeltaToInteger x 1     lim+    enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim++{-# RULES+"enumDeltaInteger"      [~1] forall x y.  enumDeltaInteger x y     = build (\c _ -> enumDeltaIntegerFB c x y)+"efdtInteger"           [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)+"enumDeltaInteger"      [1] enumDeltaIntegerFB   (:)    = enumDeltaInteger+"enumDeltaToInteger"    [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger+ #-}++enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b+enumDeltaIntegerFB c x d = x `seq` (x `c` enumDeltaIntegerFB c (x+d) d)++enumDeltaInteger :: Integer -> Integer -> [Integer]+enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d)+-- strict accumulator, so+--     head (drop 1000000 [1 .. ]+-- works++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++enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer]+enumDeltaToInteger x delta lim+  | delta >= 0 = up_list x delta lim+  | otherwise  = dn_list x delta lim++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)+\end{code}+
GHC/PArr.hs view
@@ -1,2 +1,732 @@-module GHC.PArr (module X___) where-import "base" GHC.PArr as X___+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# LANGUAGE PArr #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.PArr+-- Copyright   :  (c) 2001-2002 Manuel M T Chakravarty & Gabriele Keller+-- License     :  see libraries/base/LICENSE+-- +-- Maintainer  :  Manuel M. T. Chakravarty <chak@cse.unsw.edu.au>+-- Stability   :  internal+-- Portability :  non-portable (GHC Extensions)+--+--  Basic implementation of Parallel Arrays.+--+--  This module has two functions: (1) It defines the interface to the+--  parallel array extension of the Prelude and (2) it provides a vanilla+--  implementation of parallel arrays that does not require to flatten the+--  array code.  The implementation is not very optimised.+--+--- DOCU ----------------------------------------------------------------------+--+--  Language: Haskell 98 plus unboxed values and parallel arrays+--+--  The semantic difference between standard Haskell arrays (aka "lazy+--  arrays") and parallel arrays (aka "strict arrays") is that the evaluation+--  of two different elements of a lazy array is independent, whereas in a+--  strict array either non or all elements are evaluated.  In other words,+--  when a parallel array is evaluated to WHNF, all its elements will be+--  evaluated to WHNF.  The name parallel array indicates that all array+--  elements may, in general, be evaluated to WHNF in parallel without any+--  need to resort to speculative evaluation.  This parallel evaluation+--  semantics is also beneficial in the sequential case, as it facilitates+--  loop-based array processing as known from classic array-based languages,+--  such as Fortran.+--+--  The interface of this module is essentially a variant of the list+--  component of the Prelude, but also includes some functions (such as+--  permutations) that are not provided for lists.  The following list+--  operations are not supported on parallel arrays, as they would require the+--  availability of infinite parallel arrays: `iterate', `repeat', and `cycle'.+--+--  The current implementation is quite simple and entirely based on boxed+--  arrays.  One disadvantage of boxed arrays is that they require to+--  immediately initialise all newly allocated arrays with an error thunk to+--  keep the garbage collector happy, even if it is guaranteed that the array+--  is fully initialised with different values before passing over the+--  user-visible interface boundary.  Currently, no effort is made to use+--  raw memory copy operations to speed things up.+--+--- TODO ----------------------------------------------------------------------+--+--  * We probably want a standard library `PArray' in addition to the prelude+--    extension in the same way as the standard library `List' complements the+--    list functions from the prelude.+--+--  * Currently, functions that emphasis the constructor-based definition of+--    lists (such as, head, last, tail, and init) are not supported.  +--+--    Is it worthwhile to support the string processing functions lines,+--    words, unlines, and unwords?  (Currently, they are not implemented.)+--+--    It can, however, be argued that it would be worthwhile to include them+--    for completeness' sake; maybe only in the standard library `PArray'.+--+--  * Prescans are often more useful for array programming than scans.  Shall+--    we include them into the Prelude or the library?+--+--  * Due to the use of the iterator `loop', we could define some fusion rules+--    in this module.+--+--  * We might want to add bounds checks that can be deactivated.+--++module GHC.PArr (+  -- [::],              -- Built-in syntax++  mapP,                 -- :: (a -> b) -> [:a:] -> [:b:]+  (+:+),                -- :: [:a:] -> [:a:] -> [:a:]+  filterP,              -- :: (a -> Bool) -> [:a:] -> [:a:]+  concatP,              -- :: [:[:a:]:] -> [:a:]+  concatMapP,           -- :: (a -> [:b:]) -> [:a:] -> [:b:]+--  head, last, tail, init,   -- it's not wise to use them on arrays+  nullP,                -- :: [:a:] -> Bool+  lengthP,              -- :: [:a:] -> Int+  (!:),                 -- :: [:a:] -> Int -> a+  foldlP,               -- :: (a -> b -> a) -> a -> [:b:] -> a+  foldl1P,              -- :: (a -> a -> a) ->      [:a:] -> a+  scanlP,               -- :: (a -> b -> a) -> a -> [:b:] -> [:a:]+  scanl1P,              -- :: (a -> a -> a) ->      [:a:] -> [:a:]+  foldrP,               -- :: (a -> b -> b) -> b -> [:a:] -> b+  foldr1P,              -- :: (a -> a -> a) ->      [:a:] -> a+  scanrP,               -- :: (a -> b -> b) -> b -> [:a:] -> [:b:]+  scanr1P,              -- :: (a -> a -> a) ->      [:a:] -> [:a:]+--  iterate, repeat,          -- parallel arrays must be finite+  singletonP,           -- :: a -> [:a:]+  emptyP,               -- :: [:a:]+  replicateP,           -- :: Int -> a -> [:a:]+--  cycle,                    -- parallel arrays must be finite+  takeP,                -- :: Int -> [:a:] -> [:a:]+  dropP,                -- :: Int -> [:a:] -> [:a:]+  splitAtP,             -- :: Int -> [:a:] -> ([:a:],[:a:])+  takeWhileP,           -- :: (a -> Bool) -> [:a:] -> [:a:]+  dropWhileP,           -- :: (a -> Bool) -> [:a:] -> [:a:]+  spanP,                -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])+  breakP,               -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])+--  lines, words, unlines, unwords,  -- is string processing really needed+  reverseP,             -- :: [:a:] -> [:a:]+  andP,                 -- :: [:Bool:] -> Bool+  orP,                  -- :: [:Bool:] -> Bool+  anyP,                 -- :: (a -> Bool) -> [:a:] -> Bool+  allP,                 -- :: (a -> Bool) -> [:a:] -> Bool+  elemP,                -- :: (Eq a) => a -> [:a:] -> Bool+  notElemP,             -- :: (Eq a) => a -> [:a:] -> Bool+  lookupP,              -- :: (Eq a) => a -> [:(a, b):] -> Maybe b+  sumP,                 -- :: (Num a) => [:a:] -> a+  productP,             -- :: (Num a) => [:a:] -> a+  maximumP,             -- :: (Ord a) => [:a:] -> a+  minimumP,             -- :: (Ord a) => [:a:] -> a+  zipP,                 -- :: [:a:] -> [:b:]          -> [:(a, b)   :]+  zip3P,                -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]+  zipWithP,             -- :: (a -> b -> c)      -> [:a:] -> [:b:] -> [:c:]+  zipWith3P,            -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]+  unzipP,               -- :: [:(a, b)   :] -> ([:a:], [:b:])+  unzip3P,              -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])++  -- overloaded functions+  --+  enumFromToP,          -- :: Enum a => a -> a      -> [:a:]+  enumFromThenToP,      -- :: Enum a => a -> a -> a -> [:a:]++  -- the following functions are not available on lists+  --+  toP,                  -- :: [a] -> [:a:]+  fromP,                -- :: [:a:] -> [a]+  sliceP,               -- :: Int -> Int -> [:e:] -> [:e:]+  foldP,                -- :: (e -> e -> e) -> e -> [:e:] -> e+  fold1P,               -- :: (e -> e -> e) ->      [:e:] -> e+  permuteP,             -- :: [:Int:] -> [:e:] ->          [:e:]+  bpermuteP,            -- :: [:Int:] -> [:e:] ->          [:e:]+  dpermuteP,            -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]+  crossP,               -- :: [:a:] -> [:b:] -> [:(a, b):]+  crossMapP,            -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]+  indexOfP              -- :: (a -> Bool) -> [:a:] -> [:Int:]+) where++#ifndef __HADDOCK__++import Prelude++import GHC.ST   ( ST(..), runST )+import GHC.Base ( Int#, Array#, Int(I#), MutableArray#, newArray#,+                  unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) )++infixl 9  !:+infixr 5  +:++infix  4  `elemP`, `notElemP`+++-- representation of parallel arrays+-- ---------------------------------++-- this rather straight forward implementation maps parallel arrays to the+-- internal representation used for standard Haskell arrays in GHC's Prelude+-- (EXPORTED ABSTRACTLY)+--+-- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'!+--+data [::] e = PArr Int# (Array# e)+++-- exported operations on parallel arrays+-- --------------------------------------++-- operations corresponding to list operations+--++mapP   :: (a -> b) -> [:a:] -> [:b:]+mapP f  = fst . loop (mapEFL f) noAL++(+:+)     :: [:a:] -> [:a:] -> [:a:]+a1 +:+ a2  = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1))+                       -- we can't use the [:x..y:] form here for tedious+                       -- reasons to do with the typechecker and the fact that+                       -- `enumFromToP' is defined in the same module+             where+               len1 = lengthP a1+               len2 = lengthP a2+               --+               sel i | i < len1  = a1!:i+                     | otherwise = a2!:(i - len1)++filterP   :: (a -> Bool) -> [:a:] -> [:a:]+filterP p  = fst . loop (filterEFL p) noAL++concatP     :: [:[:a:]:] -> [:a:]+concatP xss  = foldlP (+:+) [::] xss++concatMapP   :: (a -> [:b:]) -> [:a:] -> [:b:]+concatMapP f  = concatP . mapP f++--  head, last, tail, init,   -- it's not wise to use them on arrays++nullP      :: [:a:] -> Bool+nullP [::]  = True+nullP _     = False++lengthP             :: [:a:] -> Int+lengthP (PArr n# _)  = I# n#++(!:) :: [:a:] -> Int -> a+(!:)  = indexPArr++foldlP     :: (a -> b -> a) -> a -> [:b:] -> a+foldlP f z  = snd . loop (foldEFL (flip f)) z++foldl1P        :: (a -> a -> a) -> [:a:] -> a+foldl1P _ [::]  = error "Prelude.foldl1P: empty array"+foldl1P f a     = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a++scanlP     :: (a -> b -> a) -> a -> [:b:] -> [:a:]+scanlP f z  = fst . loop (scanEFL (flip f)) z++scanl1P        :: (a -> a -> a) -> [:a:] -> [:a:]+scanl1P _ [::]  = error "Prelude.scanl1P: empty array"+scanl1P f a     = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a++foldrP :: (a -> b -> b) -> b -> [:a:] -> b+foldrP  = error "Prelude.foldrP: not implemented yet" -- FIXME++foldr1P :: (a -> a -> a) -> [:a:] -> a+foldr1P  = error "Prelude.foldr1P: not implemented yet" -- FIXME++scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:]+scanrP  = error "Prelude.scanrP: not implemented yet" -- FIXME++scanr1P :: (a -> a -> a) -> [:a:] -> [:a:]+scanr1P  = error "Prelude.scanr1P: not implemented yet" -- FIXME++--  iterate, repeat           -- parallel arrays must be finite++singletonP             :: a -> [:a:]+{-# INLINE singletonP #-}+singletonP e = replicateP 1 e+  +emptyP:: [:a:]+{- NOINLINE emptyP #-}+emptyP = replicateP 0 undefined+++replicateP             :: Int -> a -> [:a:]+{-# INLINE replicateP #-}+replicateP n e  = runST (do+  marr# <- newArray n e+  mkPArr n marr#)++--  cycle                     -- parallel arrays must be finite++takeP   :: Int -> [:a:] -> [:a:]+takeP n  = sliceP 0 (n - 1)++dropP     :: Int -> [:a:] -> [:a:]+dropP n a  = sliceP n (lengthP a - 1) a++splitAtP      :: Int -> [:a:] -> ([:a:],[:a:])+splitAtP n xs  = (takeP n xs, dropP n xs)++takeWhileP :: (a -> Bool) -> [:a:] -> [:a:]+takeWhileP  = error "Prelude.takeWhileP: not implemented yet" -- FIXME++dropWhileP :: (a -> Bool) -> [:a:] -> [:a:]+dropWhileP  = error "Prelude.dropWhileP: not implemented yet" -- FIXME++spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])+spanP  = error "Prelude.spanP: not implemented yet" -- FIXME++breakP   :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])+breakP p  = spanP (not . p)++--  lines, words, unlines, unwords,  -- is string processing really needed++reverseP   :: [:a:] -> [:a:]+reverseP a  = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a+                       -- we can't use the [:x, y..z:] form here for tedious+                       -- reasons to do with the typechecker and the fact that+                       -- `enumFromThenToP' is defined in the same module+              where+                len = lengthP a++andP :: [:Bool:] -> Bool+andP  = foldP (&&) True++orP :: [:Bool:] -> Bool+orP  = foldP (||) True++anyP   :: (a -> Bool) -> [:a:] -> Bool+anyP p  = orP . mapP p++allP :: (a -> Bool) -> [:a:] -> Bool+allP p  = andP . mapP p++elemP   :: (Eq a) => a -> [:a:] -> Bool+elemP x  = anyP (== x)++notElemP   :: (Eq a) => a -> [:a:] -> Bool+notElemP x  = allP (/= x)++lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b+lookupP  = error "Prelude.lookupP: not implemented yet" -- FIXME++sumP :: (Num a) => [:a:] -> a+sumP  = foldP (+) 0++productP :: (Num a) => [:a:] -> a+productP  = foldP (*) 1++maximumP      :: (Ord a) => [:a:] -> a+maximumP [::]  = error "Prelude.maximumP: empty parallel array"+maximumP xs    = fold1P max xs++minimumP :: (Ord a) => [:a:] -> a+minimumP [::]  = error "Prelude.minimumP: empty parallel array"+minimumP xs    = fold1P min xs++zipP :: [:a:] -> [:b:] -> [:(a, b):]+zipP  = zipWithP (,)++zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]+zip3P  = zipWith3P (,,)++zipWithP         :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]+zipWithP f a1 a2  = let +                      len1 = lengthP a1+                      len2 = lengthP a2+                      len  = len1 `min` len2+                    in+                    fst $ loopFromTo 0 (len - 1) combine 0 a1+                    where+                      combine e1 i = (Just $ f e1 (a2!:i), i + 1)++zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]+zipWith3P f a1 a2 a3 = let +                        len1 = lengthP a1+                        len2 = lengthP a2+                        len3 = lengthP a3+                        len  = len1 `min` len2 `min` len3+                      in+                      fst $ loopFromTo 0 (len - 1) combine 0 a1+                      where+                        combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1)++unzipP   :: [:(a, b):] -> ([:a:], [:b:])+unzipP a  = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a)+-- FIXME: these two functions should be optimised using a tupled custom loop+unzip3P   :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])+unzip3P x  = (fst $ loop (mapEFL fst3) noAL x, +              fst $ loop (mapEFL snd3) noAL x,+              fst $ loop (mapEFL trd3) noAL x)+             where+               fst3 (a, _, _) = a+               snd3 (_, b, _) = b+               trd3 (_, _, c) = c++-- instances+--++instance Eq a => Eq [:a:] where+  a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2)+           | otherwise                = False++instance Ord a => Ord [:a:] where+  compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of+                    EQ | lengthP a1 == lengthP a2 -> EQ+                       | lengthP a1 <  lengthP a2 -> LT+                       | otherwise                -> GT+                  where+                    combineOrdering EQ    EQ    = EQ+                    combineOrdering EQ    other = other+                    combineOrdering other _     = other++instance Functor [::] where+  fmap = mapP++instance Monad [::] where+  m >>= k  = foldrP ((+:+) . k      ) [::] m+  m >>  k  = foldrP ((+:+) . const k) [::] m+  return x = [:x:]+  fail _   = [::]++instance Show a => Show [:a:]  where+  showsPrec _  = showPArr . fromP+    where+      showPArr []     s = "[::]" ++ s+      showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s)++      showPArr' []     s = ":]" ++ s+      showPArr' (y:ys) s = ',' : shows y (showPArr' ys s)++instance Read a => Read [:a:]  where+  readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a]+    where+      readPArr = readParen False (\r -> do+                                          ("[:",s) <- lex r+                                          readPArr1 s)+      readPArr1 s = +        (do { (":]", t) <- lex s; return ([], t) }) +++        (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) })++      readPArr2 s = +        (do { (":]", t) <- lex s; return ([], t) }) +++        (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; +              return (x:xs, v) })++-- overloaded functions+-- ++-- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of+-- `Enum'.  On the other hand, we really do not want to change `Enum'.  Thus,+-- for the moment, we hope that the compiler is sufficiently clever to+-- properly fuse the following definitions.++enumFromToP     :: Enum a => a -> a -> [:a:]+enumFromToP x0 y0  = mapP toEnum (eftInt (fromEnum x0) (fromEnum y0))+  where+    eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1++enumFromThenToP       :: Enum a => a -> a -> a -> [:a:]+enumFromThenToP x0 y0 z0  = +  mapP toEnum (efttInt (fromEnum x0) (fromEnum y0) (fromEnum z0))+  where+    efttInt x y z = scanlP (+) x $ +                      replicateP (abs (z - x) `div` abs delta + 1) delta+      where+       delta = y - x++-- the following functions are not available on lists+--++-- create an array from a list (EXPORTED)+--+toP   :: [a] -> [:a:]+toP l  = fst $ loop store l (replicateP (length l) ())+         where+           store _ (x:xs) = (Just x, xs)++-- convert an array to a list (EXPORTED)+--+fromP   :: [:a:] -> [a]+fromP a  = [a!:i | i <- [0..lengthP a - 1]]++-- cut a subarray out of an array (EXPORTED)+--+sliceP :: Int -> Int -> [:e:] -> [:e:]+sliceP from to a = +  fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a++-- parallel folding (EXPORTED)+--+-- * the first argument must be associative; otherwise, the result is undefined+--+foldP :: (e -> e -> e) -> e -> [:e:] -> e+foldP  = foldlP++-- parallel folding without explicit neutral (EXPORTED)+--+-- * the first argument must be associative; otherwise, the result is undefined+--+fold1P :: (e -> e -> e) -> [:e:] -> e+fold1P  = foldl1P++-- permute an array according to the permutation vector in the first argument+-- (EXPORTED)+--+permuteP       :: [:Int:] -> [:e:] -> [:e:]+permuteP is es +  | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"+  | otherwise      = runST (do+                       marr <- newArray isLen noElem+                       permute marr is es+                       mkPArr isLen marr)+  where+    noElem = error "GHC.PArr.permuteP: I do not exist!"+             -- unlike standard Haskell arrays, this value represents an+             -- internal error+    isLen = lengthP is+    esLen = lengthP es++-- permute an array according to the back-permutation vector in the first+-- argument (EXPORTED)+--+-- * the permutation vector must represent a surjective function; otherwise,+--   the result is undefined+--+bpermuteP       :: [:Int:] -> [:e:] -> [:e:]+bpermuteP is es  = fst $ loop (mapEFL (es!:)) noAL is++-- permute an array according to the permutation vector in the first+-- argument, which need not be surjective (EXPORTED)+--+-- * any elements in the result that are not covered by the permutation+--   vector assume the value of the corresponding position of the third+--   argument +--+dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:]+dpermuteP is es dft+  | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"+  | otherwise      = runST (do+                       marr <- newArray dftLen noElem+                       trans 0 (isLen - 1) marr dft copyOne noAL+                       permute marr is es+                       mkPArr dftLen marr)+  where+    noElem = error "GHC.PArr.permuteP: I do not exist!"+             -- unlike standard Haskell arrays, this value represents an+             -- internal error+    isLen  = lengthP is+    esLen  = lengthP es+    dftLen = lengthP dft++    copyOne e _ = (Just e, noAL)++-- computes the cross combination of two arrays (EXPORTED)+--+crossP       :: [:a:] -> [:b:] -> [:(a, b):]+crossP a1 a2  = fst $ loop combine (0, 0) $ replicateP len ()+                where+                  len1 = lengthP a1+                  len2 = lengthP a2+                  len  = len1 * len2+                  --+                  combine _ (i, j) = (Just $ (a1!:i, a2!:j), next)+                                     where+                                       next | (i + 1) == len1 = (0    , j + 1)+                                            | otherwise       = (i + 1, j)++{- An alternative implementation+   * The one above is certainly better for flattened code, but here where we+     are handling boxed arrays, the trade off is less clear.  However, I+     think, the above one is still better.++crossP a1 a2  = let+                  len1 = lengthP a1+                  len2 = lengthP a2+                  x1   = concatP $ mapP (replicateP len2) a1+                  x2   = concatP $ replicateP len1 a2+                in+                zipP x1 x2+ -}++-- |Compute a cross of an array and the arrays produced by the given function+-- for the elements of the first array.+--+crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]+crossMapP a f = let+                  bs   = mapP f a+                  segd = mapP lengthP bs+                  as   = zipWithP replicateP segd a+                in+                zipP (concatP as) (concatP bs)++{- The following may seem more straight forward, but the above is very cheap+   with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are+   constant time, and `map f' uses the lifted version of `f'.++crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a++ -}++-- computes an index array for all elements of the second argument for which+-- the predicate yields `True' (EXPORTED)+--+indexOfP     :: (a -> Bool) -> [:a:] -> [:Int:]+indexOfP p a  = fst $ loop calcIdx 0 a+                where+                  calcIdx e idx | p e       = (Just idx, idx + 1)+                                | otherwise = (Nothing , idx    )+++-- auxiliary functions+-- -------------------++-- internally used mutable boxed arrays+--+data MPArr s e = MPArr Int# (MutableArray# s e)++-- allocate a new mutable array that is pre-initialised with a given value+--+newArray             :: Int -> e -> ST s (MPArr s e)+{-# INLINE newArray #-}+newArray (I# n#) e  = ST $ \s1# ->+  case newArray# n# e s1# of { (# s2#, marr# #) ->+  (# s2#, MPArr n# marr# #)}++-- convert a mutable array into the external parallel array representation+--+mkPArr                           :: Int -> MPArr s e -> ST s [:e:]+{-# INLINE mkPArr #-}+mkPArr (I# n#) (MPArr _ marr#)  = ST $ \s1# ->+  case unsafeFreezeArray# marr# s1#   of { (# s2#, arr# #) ->+  (# s2#, PArr n# arr# #) }++-- general array iterator+--+-- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty &+--   Keller, ICFP 2001+--+loop :: (e -> acc -> (Maybe e', acc))    -- mapping & folding, once per element+     -> acc                              -- initial acc value+     -> [:e:]                            -- input array+     -> ([:e':], acc)+{-# INLINE loop #-}+loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr++-- general array iterator with bounds+--+loopFromTo :: Int                        -- from index+           -> Int                        -- to index+           -> (e -> acc -> (Maybe e', acc))+           -> acc+           -> [:e:]+           -> ([:e':], acc)+{-# INLINE loopFromTo #-}+loopFromTo from to mf start arr = runST (do+  marr      <- newArray (to - from + 1) noElem+  (n', acc) <- trans from to marr arr mf start+  arr'      <- mkPArr n' marr+  return (arr', acc))+  where+    noElem = error "GHC.PArr.loopFromTo: I do not exist!"+             -- unlike standard Haskell arrays, this value represents an+             -- internal error++-- actual loop body of `loop'+--+-- * for this to be really efficient, it has to be translated with the+--   constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03+--   this requires an optimisation level of at least -O2+--+trans :: Int                            -- index of first elem to process+      -> Int                            -- index of last elem to process+      -> MPArr s e'                     -- destination array+      -> [:e:]                          -- source array+      -> (e -> acc -> (Maybe e', acc))  -- mutator+      -> acc                            -- initial accumulator+      -> ST s (Int, acc)                -- final destination length/final acc+{-# INLINE trans #-}+trans from to marr arr mf start = trans' from 0 start+  where+    trans' arrOff marrOff acc +      | arrOff > to = return (marrOff, acc)+      | otherwise   = do+                        let (oe', acc') = mf (arr `indexPArr` arrOff) acc+                        marrOff' <- case oe' of+                                      Nothing -> return marrOff +                                      Just e' -> do+                                        writeMPArr marr marrOff e'+                                        return $ marrOff + 1+                        trans' (arrOff + 1) marrOff' acc'++-- Permute the given elements into the mutable array.+--+permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s ()+permute marr is es = perm 0+  where+    perm i+      | i == n = return ()+      | otherwise  = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1)+      where+        n = lengthP is+++-- common patterns for using `loop'+--++-- initial value for the accumulator when the accumulator is not needed+--+noAL :: ()+noAL  = ()++-- `loop' mutator maps a function over array elements+--+mapEFL   :: (e -> e') -> (e -> () -> (Maybe e', ()))+{-# INLINE mapEFL #-}+mapEFL f  = \e _ -> (Just $ f e, ())++-- `loop' mutator that filter elements according to a predicate+--+filterEFL   :: (e -> Bool) -> (e -> () -> (Maybe e, ()))+{-# INLINE filterEFL #-}+filterEFL p  = \e _ -> if p e then (Just e, ()) else (Nothing, ())++-- `loop' mutator for array folding+--+foldEFL   :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc))+{-# INLINE foldEFL #-}+foldEFL f  = \e a -> (Nothing, f e a)++-- `loop' mutator for array scanning+--+scanEFL   :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc))+{-# INLINE scanEFL #-}+scanEFL f  = \e a -> (Just a, f e a)++-- elementary array operations+--++-- unlifted array indexing +--+indexPArr                       :: [:e:] -> Int -> e+{-# INLINE indexPArr #-}+indexPArr (PArr n# arr#) (I# i#) +  | i# >=# 0# && i# <# n# =+    case indexArray# arr# i# of (# e #) -> e+  | otherwise = error $ "indexPArr: out of bounds parallel array index; " +++                        "idx = " ++ show (I# i#) ++ ", arr len = "+                        ++ show (I# n#)++-- encapsulate writing into a mutable array into the `ST' monad+--+writeMPArr                           :: MPArr s e -> Int -> e -> ST s ()+{-# INLINE writeMPArr #-}+writeMPArr (MPArr n# marr#) (I# i#) e +  | i# >=# 0# && i# <# n# =+    ST $ \s# ->+    case writeArray# marr# i# e s# of s'# -> (# s'#, () #)+  | otherwise = error $ "writeMPArr: out of bounds parallel array index; " +++                        "idx = " ++ show (I# i#) ++ ", arr len = "+                        ++ show (I# n#)++#endif /* __HADDOCK__ */+
− GHC/Pack.hs 
@@ -1,2 +0,0 @@-module GHC.Pack (module X___) where-import "base" GHC.Pack as X___
+ GHC/Pack.lhs view
@@ -0,0 +1,104 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Pack+       (+        -- (**) - emitted by compiler.++        packCString#,      -- :: [Char] -> ByteArray#    (**)+        unpackCString,+        unpackCString#,    -- :: Addr# -> [Char]         (**)+        unpackNBytes#,     -- :: Addr# -> Int# -> [Char] (**)+        unpackFoldrCString#,  -- (**)+        unpackAppendCString#,  -- (**)+       ) +        where++import GHC.Base+import GHC.Err ( error )+import GHC.List ( length )+import GHC.ST+import GHC.Num+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 = error "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# #) }+\end{code}
− GHC/Ptr.hs 
@@ -1,2 +0,0 @@-module GHC.Ptr (module X___) where-import "base" GHC.Ptr as X___
+ GHC/Ptr.lhs view
@@ -0,0 +1,162 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Ptr where++import GHC.Base+import GHC.Show+import GHC.Num+import GHC.List ( length, replicate )+import Numeric          ( showHex )++#include "MachDeps.h"++------------------------------------------------------------------------+-- Data pointers.++data Ptr a = Ptr Addr# deriving (Eq, Ord)+-- ^ 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 (Ptr addr) = Ptr addr++-- |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.++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', 'Prelude.Double', 'Prelude.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+--   @'Prelude.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 (FunPtr addr) = FunPtr addr++-- |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+-- I have absolutely no idea why the WORD_SIZE_IN_BITS stuff is here++#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)+instance Show (Ptr a) where+   showsPrec _ (Ptr a) rs = pad_out (showHex (wordToInteger(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++instance Show (FunPtr a) where+   showsPrec p = showsPrec p . castFunPtrToPtr+#endif+\end{code}+
− GHC/Read.hs 
@@ -1,2 +0,0 @@-module GHC.Read (module X___) where-import "base" GHC.Read as X___
+ GHC/Read.lhs view
@@ -0,0 +1,676 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Read+  ( Read(..)   -- class++  -- ReadS type+  , ReadS      -- :: *; = String -> [(a,String)]++  -- H98 compatibility+  , lex         -- :: ReadS String+  , lexLitChar  -- :: ReadS String+  , readLitChar -- :: ReadS Char+  , lexDigits   -- :: ReadS String++  -- defining readers+  , lexP       -- :: ReadPrec Lexeme+  , paren      -- :: ReadPrec a -> ReadPrec a+  , parens     -- :: ReadPrec a -> ReadPrec a+  , list       -- :: ReadPrec a -> ReadPrec [a]+  , choose     -- :: [(String, ReadPrec a)] -> ReadPrec a+  , readListDefault, readListPrecDefault++  -- Temporary+  , readParen++  -- XXX Can this be removed?+  , readp+  )+ where++import qualified Text.ParserCombinators.ReadP as P++import Text.ParserCombinators.ReadP+  ( 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++#ifndef __HADDOCK__+import {-# SOURCE #-} GHC.Unicode       ( isDigit )+#endif+import GHC.Num+import GHC.Real+import GHC.Float ()+import GHC.Show+import GHC.Base+import GHC.Arr+\end{code}+++\begin{code}+-- | @'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 98 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)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Read@ class}+%*                                                      *+%*********************************************************++\begin{code}+------------------------------------------------------------------------+-- class Read++-- | Parsing of 'String's, producing values.+--+-- Minimal complete definition: 'readsPrec' (or, for GHC only, 'readPrec')+--+-- 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 98 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++class Read a where+  -- | 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++------------------------------------------------------------------------+-- H98 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 H98+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 H98+lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;+                              return s })+        -- 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 H98+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++paren :: ReadPrec a -> ReadPrec a+-- ^ @(paren p)@ parses \"(P0)\"+--      where @p@ parses \"P0\" in precedence context zero+paren p = do L.Punc "(" <- lexP+             x          <- reset p+             L.Punc ")" <- lexP+             return 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  = 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 L.Punc "[" <- lexP+       (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)]@+choose sps = foldr ((+++) . try_one) pfail sps+           where+             try_one (s,p) = do { L.Ident s' <- lexP ;+                                  if s == s' then p else pfail }+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Simple instances of Read}+%*                                                      *+%*********************************************************++\begin{code}+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 H98 spec)++  readList = readListDefault++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++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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{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'.++\begin{code}+instance Read a => Read (Maybe a) where+  readPrec =+    parens+    (do L.Ident "Nothing" <- lexP+        return Nothing+     ++++     prec appPrec (+        do L.Ident "Just" <- lexP+           x              <- step readPrec+           return (Just x))+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read a => Read [a] where+  readPrec     = readListPrec+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance  (Ix a, Read a, Read b) => Read (Array a b)  where+    readPrec = parens $ prec appPrec $+               do L.Ident "array" <- lexP+                  theBounds <- step readPrec+                  vals   <- step readPrec+                  return (array theBounds vals)++    readListPrec = readListPrecDefault+    readList     = readListDefault++instance Read L.Lexeme where+  readPrec     = lexP+  readListPrec = readListPrecDefault+  readList     = readListDefault+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Numeric instances of Read}+%*                                                      *+%*********************************************************++\begin{code}+readNumber :: Num a => (L.Lexeme -> Maybe a) -> ReadPrec a+-- Read a signed number+readNumber convert =+  parens+  ( do x <- lexP+       case x of+         L.Symbol "-" -> do n <- readNumber convert+                            return (negate n)+       +         _   -> case convert x of+                   Just n  -> return n+                   Nothing -> pfail+  )++convertInt :: Num a => L.Lexeme -> Maybe a+convertInt (L.Int i) = Just (fromInteger i)+convertInt _         = Nothing++convertFrac :: Fractional a => L.Lexeme -> Maybe a+convertFrac (L.Int i) = Just (fromInteger i)+convertFrac (L.Rat r) = Just (fromRational r)+convertFrac _         = Nothing++instance Read Int where+  readPrec     = readNumber convertInt+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Integer where+  readPrec     = readNumber convertInt+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Float where+  readPrec     = readNumber convertFrac+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance Read Double where+  readPrec     = readNumber convertFrac+  readListPrec = readListPrecDefault+  readList     = readListDefault++instance (Integral a, Read a) => Read (Ratio a) where+  readPrec =+    parens+    ( prec ratioPrec+      ( do x            <- step readPrec+           L.Symbol "%" <- lexP+           y            <- step readPrec+           return (x % y)+      )+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault+\end{code}+++%*********************************************************+%*                                                      *+        Tuple instances of Read, up to size 15+%*                                                      *+%*********************************************************++\begin{code}+instance Read () where+  readPrec =+    parens+    ( paren+      ( return ()+      )+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault++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 = do { L.Punc "," <- lexP; return () }++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)+++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++instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where+  readPrec = wrap_tup read_tup4+  readListPrec = readListPrecDefault+  readList     = readListDefault++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++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++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++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++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++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++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++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++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++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++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+\end{code}++\begin{code}+-- XXX Can this be removed?++readp :: Read a => ReadP a+readp = readPrec_to_P readPrec minPrec+\end{code}+
− GHC/Real.hs 
@@ -1,2 +0,0 @@-module GHC.Real (module X___) where-import "base" GHC.Real as X___
+ GHC/Real.lhs view
@@ -0,0 +1,480 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.Real+-- Copyright   :  (c) The FFI Task Force, 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'.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Real where++import GHC.Base+import GHC.Num+import GHC.List+import GHC.Enum+import GHC.Show++infixr 8  ^, ^^+infixl 7  /, `quot`, `rem`, `div`, `mod`+infixl 7  %++default ()              -- Double isn't available yet, +                        -- and we shouldn't be using defaults anyway+\end{code}+++%*********************************************************+%*                                                      *+\subsection{The @Ratio@ and @Rational@ types}+%*                                                      *+%*********************************************************++\begin{code}+-- | Rational numbers, with numerator and denominator of some 'Integral' type.+data  (Integral a)      => Ratio a = !a :% !a  deriving (Eq)++-- | 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. +\end{code}+++\begin{code}+-- | 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       :: (Integral a) => Ratio a -> a++-- | Extract the denominator of the ratio in reduced form:+-- the numerator and denominator have no common factor and the denominator+-- is positive.+denominator     :: (Integral a) => Ratio a -> a+\end{code}++\tr{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.++\begin{code}+reduce ::  (Integral a) => a -> a -> Ratio a+{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}+reduce _ 0              =  error "Ratio.%: zero denominator"+reduce x y              =  (x `quot` d) :% (y `quot` d)+                           where d = gcd x y+\end{code}++\begin{code}+x % y                   =  reduce (x * signum y) (abs y)++numerator   (x :% _)    =  x+denominator (_ :% y)    =  y+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Standard numeric classes}+%*                                                      *+%*********************************************************++\begin{code}+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.+--+-- Minimal complete definition: 'quotRem' and 'toInteger'+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++    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.+--+-- Minimal complete definition: 'fromRational' and ('recip' or @('/')@)+class  (Num a) => Fractional a  where+    -- | 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++    recip x             =  1 / x+    x / y               = x * recip y++-- | Extracting components of fractions.+--+-- Minimal complete definition: 'properFraction'+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@+    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++    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+                                _  -> error "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+\end{code}+++These 'numeric' enumerations come straight from the Report++\begin{code}+numericEnumFrom         :: (Fractional a) => a -> [a]+numericEnumFrom n	=  n `seq` (n : numericEnumFrom (n + 1))++numericEnumFromThen     :: (Fractional a) => a -> a -> [a]+numericEnumFromThen n m	= n `seq` m `seq` (n : numericEnumFromThen m (m+m-n))++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)+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Int@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Real Int  where+    toRational x        =  toInteger x % 1++instance  Integral Int  where+    toInteger (I# i) = smallInteger i++    a `quot` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `quotInt` b++    a `rem` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `remInt` b++    a `div` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `divInt` b++    a `mod` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `modInt` b++    a `quotRem` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `quotRemInt` b++    a `divMod` b+     | b == 0                     = divZeroError+     | a == minBound && b == (-1) = overflowError+     | otherwise                  =  a `divModInt` b+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Integer@}+%*                                                      *+%*********************************************************++\begin{code}+instance  Real Integer  where+    toRational x        =  x % 1++instance  Integral Integer where+    toInteger n      = n++    _ `quot` 0 = divZeroError+    n `quot` d = n `quotInteger` d++    _ `rem` 0 = divZeroError+    n `rem`  d = n `remInteger`  d++    _ `divMod` 0 = divZeroError+    a `divMod` b = case a `divModInteger` b of+                   (# x, y #) -> (x, y)++    _ `quotRem` 0 = divZeroError+    a `quotRem` b = case a `quotRemInteger` b of+                    (# q, r #) -> (q, r)++    -- use the defaults for div & mod+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Instances for @Ratio@}+%*                                                      *+%*********************************************************++\begin{code}+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++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++instance  (Integral a)  => Fractional (Ratio a)  where+    {-# SPECIALIZE instance Fractional Rational #-}+    (x:%y) / (x':%y')   =  (x*y') % (y*x')+    recip (x:%y)        =  y % x+    fromRational (x:%y) =  fromInteger x :% fromInteger y++instance  (Integral a)  => Real (Ratio a)  where+    {-# SPECIALIZE instance Real Rational #-}+    toRational (x:%y)   =  toInteger x :% toInteger y++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++instance  (Integral 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++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+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Coercions}+%*                                                      *+%*********************************************************++\begin{code}+-- | general coercion from integral types+fromIntegral :: (Integral a, Num b) => a -> b+fromIntegral = fromInteger . toInteger++{-# RULES+"fromIntegral/Int->Int" fromIntegral = id :: Int -> Int+    #-}++-- | general coercion to fractional types+realToFrac :: (Real a, Fractional b) => a -> b+realToFrac = fromRational . toRational++{-# RULES+"realToFrac/Int->Int" realToFrac = id :: Int -> Int+    #-}+\end{code}++%*********************************************************+%*                                                      *+\subsection{Overloaded numeric functions}+%*                                                      *+%*********************************************************++\begin{code}+-- | 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++-------------------------------------------------------+-- | raise a number to a non-negative integral power+{-# SPECIALISE (^) ::+        Integer -> Integer -> Integer,+        Integer -> Int -> Integer,+        Int -> Int -> Int #-}+(^) :: (Num a, Integral b) => a -> b -> a+x0 ^ y0 | y0 < 0    = error "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 - 1) `quot` 2) x+          -- 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 - 1) `quot` 2) (x * z)++-- | raise a number to an integral power+{-# SPECIALISE (^^) ::+        Rational -> Int -> Rational #-}+(^^)            :: (Fractional a, Integral b) => a -> b -> a+x ^^ n          =  if n >= 0 then x^n else recip (x^(negate n))+++-------------------------------------------------------+-- | @'gcd' x y@ is the greatest (positive) integer that divides both @x@+-- and @y@; for example @'gcd' (-3) 6@ = @3@, @'gcd' (-3) (-6)@ = @3@,+-- @'gcd' 0 4@ = @4@.  @'gcd' 0 0@ raises a runtime error.+gcd             :: (Integral a) => a -> a -> a+gcd 0 0         =  error "Prelude.gcd: gcd 0 0 is undefined"+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 #-}+lcm _ 0         =  0+lcm 0 _         =  0+lcm x y         =  abs ((x `quot` (gcd x y)) * y)++{-# RULES+"gcd/Int->Int->Int"             gcd = gcdInt+ #-}++-- XXX these optimisation rules are disabled for now to make it easier+--     to experiment with other Integer implementations+-- "gcd/Integer->Integer->Integer" gcd = gcdInteger'+-- "lcm/Integer->Integer->Integer" lcm = lcmInteger+--+-- gcdInteger' :: Integer -> Integer -> Integer+-- gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined"+-- gcdInteger' a b = gcdInteger a b++integralEnumFrom :: (Integral a, Bounded a) => a -> [a]+integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)]++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++integralEnumFromTo :: Integral a => a -> a -> [a]+integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m]++integralEnumFromThenTo :: Integral a => a -> a -> a -> [a]+integralEnumFromThenTo n1 n2 m+  = map fromInteger [toInteger n1, toInteger n2 .. toInteger m]+\end{code}
− GHC/ST.hs 
@@ -1,2 +0,0 @@-module GHC.ST (module X___) where-import "base" GHC.ST as X___
+ GHC/ST.lhs view
@@ -0,0 +1,165 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.ST where++import GHC.Base+import GHC.Show+import GHC.Num++default ()+\end{code}++%*********************************************************+%*                                                      *+\subsection{The @ST@ monad}+%*                                                      *+%*********************************************************++The state-transformer monad proper.  By default the monad is strict;+too many people got bitten by space leaks when it was lazy.++\begin{code}+-- | The strict state-transformer monad.+-- A computation of type @'ST' s a@ transforms an internal state indexed+-- by @s@, and returns a value of type @a@.+-- 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 #)++instance Functor (ST s) where+    fmap f (ST m) = ST $ \ s ->+      case (m s) of { (# new_s, r #) ->+      (# new_s, f r #) }++instance Monad (ST s) where+    {-# INLINE return #-}+    {-# INLINE (>>)   #-}+    {-# INLINE (>>=)  #-}+    return x = ST (\ s -> (# s, x #))+    m >> k   = m >>= \ _ -> k++    (ST m) >>= k+      = ST (\ s ->+        case (m s) of { (# new_s, r #) ->+        case (k r) of { ST k2 ->+        (k2 new_s) }})++data STret s a = STret (State# s) a++-- liftST is useful when we want a lifted result from an ST computation.  See+-- fixST below.+liftST :: ST s a -> State# s -> STret s a+liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r++{-# NOINLINE unsafeInterleaveST #-}+unsafeInterleaveST :: ST s a -> ST s a+unsafeInterleaveST (ST m) = ST ( \ s ->+    let+        r = case m s of (# _, res #) -> res+    in+    (# s, r #)+  )++-- | Allow the result of a state transformer computation to be used (lazily)+-- inside the computation.+-- Note that if @f@ is strict, @'fixST' f = _|_@.+fixST :: (a -> ST s a) -> ST s a+fixST k = ST $ \ s ->+    let ans       = liftST (k r) s+        STret _ r = ans+    in+    case ans of STret s' x -> (# s', x #)++instance  Show (ST s a)  where+    showsPrec _ _  = showString "<<ST action>>"+    showList       = showList__ (showsPrec 0)+\end{code}++Definition of runST+~~~~~~~~~~~~~~~~~~~++SLPJ 95/04: Why @runST@ must not have an unfolding; consider:+\begin{verbatim}+f x =+  runST ( \ s -> let+                    (a, s')  = newArray# 100 [] s+                    (_, s'') = fill_in_array_or_something a x s'+                  in+                  freezeArray# a s'' )+\end{verbatim}+If we inline @runST@, we'll get:+\begin{verbatim}+f x = let+        (a, s')  = newArray# 100 [] realWorld#{-NB-}+        (_, s'') = fill_in_array_or_something a x s'+      in+      freezeArray# a s''+\end{verbatim}+And now the @newArray#@ binding can be floated to become a CAF, which+is totally and utterly wrong:+\begin{verbatim}+f = let+    (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!+    in+    \ x ->+        let (_, s'') = fill_in_array_or_something a x s' in+        freezeArray# a s''+\end{verbatim}+All calls to @f@ will share a {\em single} array!  End SLPJ 95/04.++\begin{code}+{-# INLINE runST #-}+-- The INLINE prevents runSTRep getting inlined in *this* module+-- so that it is still visible when runST is inlined in an importing+-- module.  Regrettably delicate.  runST is behaving like a wrapper.++-- | Return the value computed by a state transformer computation.+-- The @forall@ ensures that the internal state used by the 'ST'+-- computation is inaccessible to the rest of the program.+runST :: (forall s. ST s a) -> a+runST st = runSTRep (case st of { ST st_rep -> st_rep })++-- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness+-- That's what the "INLINE [0]" says.+--              SLPJ Apr 99+-- {-# INLINE [0] runSTRep #-}++-- SDM: further to the above, inline phase 0 is run *before*+-- full-laziness at the moment, which means that the above comment is+-- invalid.  Inlining runSTRep doesn't make a huge amount of+-- difference, anyway.  Hence:++{-# NOINLINE runSTRep #-}+runSTRep :: (forall s. STRep s a) -> a+runSTRep st_rep = case st_rep realWorld# of+                        (# _, r #) -> r+\end{code}
− GHC/STRef.hs 
@@ -1,2 +0,0 @@-module GHC.STRef (module X___) where-import "base" GHC.STRef as X___
+ GHC/STRef.lhs view
@@ -0,0 +1,47 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.STRef where++import GHC.ST+import GHC.Base++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@++-- |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#, () #) }++-- Just pointer equality on mutable references:+instance Eq (STRef s a) where+    STRef v1# == STRef v2# = sameMutVar# v1# v2#+\end{code}
− GHC/Show.hs 
@@ -1,2 +0,0 @@-module GHC.Show (module X___) where-import "base" GHC.Show as X___
+ GHC/Show.lhs view
@@ -0,0 +1,404 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Show+        (+        Show(..), ShowS,++        -- Instances for Show: (), [], Bool, Ordering, Int, Char++        -- Show support code+        shows, showChar, showString, showParen, showList__, showSpace,+        showLitChar, protectEsc,+        intToDigit, showSignedInt,+        appPrec, appPrec1,++        -- Character operations+        asciiTab,+  )+        where++import GHC.Base+import Data.Maybe+import GHC.List ((!!), foldr1)+\end{code}++++%*********************************************************+%*                                                      *+\subsection{The @Show@ class}+%*                                                      *+%*********************************************************++\begin{code}+-- | 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.+--+-- Minimal complete definition: 'showsPrec' or 'show'.+--+-- 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+    -- | 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+\end{code}++%*********************************************************+%*                                                      *+\subsection{Simple Instances}+%*                                                      *+%*********************************************************++\begin{code}+ +instance  Show ()  where+    showsPrec _ () = showString "()"++instance Show a => Show [a]  where+    showsPrec _         = showList++instance Show Bool where+  showsPrec _ True  = showString "True"+  showsPrec _ False = showString "False"++instance Show Ordering where+  showsPrec _ LT = showString "LT"+  showsPrec _ EQ = showString "EQ"+  showsPrec _ GT = showString "GT"++instance  Show Char  where+    showsPrec _ '\'' = showString "'\\''"+    showsPrec _ c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs = showChar '"' . showl cs+                 where showl ""       s = showChar '"' s+                       showl ('"':xs) s = showString "\\\"" (showl xs s)+                       showl (x:xs)   s = showLitChar x (showl xs s)+                -- Making 's' an explicit parameter makes it clear to GHC+                -- that showl has arity 2, which avoids it allocating an extra lambda+                -- The sticking point is the recursive call to (showl xs), which+                -- it can't figure out would be ok with arity 2.++instance Show Int where+    showsPrec = showSignedInt++instance Show a => Show (Maybe a) where+    showsPrec _p Nothing s = showString "Nothing" s+    showsPrec p (Just x) s+                          = (showParen (p > appPrec) $ +                             showString "Just " . +                             showsPrec appPrec1 x) s+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Show instances for the first few tuples+%*                                                      *+%*********************************************************++\begin{code}+-- 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))))++instance  (Show a, Show b) => Show (a,b)  where+  showsPrec _ (a,b) s = show_tuple [shows a, shows b] s++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++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++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++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++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++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++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++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++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++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++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++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++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 ')'+\end{code}+++%*********************************************************+%*                                                      *+\subsection{Support code for @Show@}+%*                                                      *+%*********************************************************++\begin{code}+-- | equivalent to 'showsPrec' with a precedence of 0.+shows           :: (Show a) => a -> ShowS+shows           =  showsPrec zeroInt++-- | 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+\end{code}++Code specific for characters++\begin{code}+-- | 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, becuase otherwise it's+        -- impossible to stop (asciiTab!!ord) getting floated out as an MFE++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"] +\end{code}++Code specific for Ints.++\begin{code}+-- | 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)+    | i >=# 0#  && i <=#  9# =  unsafeChr (ord '0' `plusInt` I# i)+    | i >=# 10# && i <=# 15# =  unsafeChr (ord 'a' `minusInt` ten `plusInt` I# i)+    | otherwise           =  error ("Char.intToDigit: not a digit " ++ show (I# i))++ten :: Int+ten = I# 10#++showSignedInt :: Int -> Int -> ShowS+showSignedInt (I# p) (I# n) r+    | n <# 0# && p ># 6# = '(' : itos n (')' : r)+    | otherwise          = itos n r++itos :: Int# -> String -> String+itos n# cs+    | n# <# 0# =+        let I# minInt# = minInt in+        if n# ==# minInt#+                -- negateInt# minInt overflows, so we can't do that:+           then '-' : itos' (negateInt# (n# `quotInt#` 10#))+                             (itos' (negateInt# (n# `remInt#` 10#)) cs)+           else '-' : itos' (negateInt# n#) cs+    | otherwise = itos' n# cs+    where+    itos' :: Int# -> String -> String+    itos' x# cs'+        | x# <# 10#  = C# (chr# (ord# '0'# +# x#)) : cs'+        | otherwise = case chr# (ord# '0'# +# (x# `remInt#` 10#)) of { c# ->+                      itos' (x# `quotInt#` 10#) (C# c# : cs') }+\end{code}
− GHC/Stable.hs 
@@ -1,2 +0,0 @@-module GHC.Stable (module X___) where-import "base" GHC.Stable as X___
+ GHC/Stable.lhs view
@@ -0,0 +1,107 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Stable +        ( StablePtr(..)+        , newStablePtr          -- :: a -> IO (StablePtr a)    +        , deRefStablePtr        -- :: StablePtr a -> a+        , freeStablePtr         -- :: StablePtr a -> IO ()+        , castStablePtrToPtr    -- :: StablePtr a -> Ptr ()+        , castPtrToStablePtr    -- :: Ptr () -> StablePtr a+   ) where++import GHC.Ptr+import GHC.Base+import GHC.IOBase++-----------------------------------------------------------------------------+-- 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 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+-- 'makeStablePtr'.  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 (unsafeCoerce# 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 (unsafeCoerce# a)++instance Eq (StablePtr a) where +    (StablePtr sp1) == (StablePtr sp2) =+        case eqStablePtr# sp1 sp2 of+           0# -> False+           _  -> True+\end{code}
− GHC/Storable.hs 
@@ -1,2 +0,0 @@-module GHC.Storable (module X___) where-import "base" GHC.Storable as X___
+ GHC/Storable.lhs view
@@ -0,0 +1,164 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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"+--+-----------------------------------------------------------------------------++-- #hide+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.IOBase+import GHC.Base+\end{code}++\begin{code}++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, () #)++\end{code}
− GHC/TopHandler.hs 
@@ -1,2 +0,0 @@-module GHC.TopHandler (module X___) where-import "base" GHC.TopHandler as X___
+ GHC/TopHandler.lhs view
@@ -0,0 +1,211 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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)+--+-----------------------------------------------------------------------------++-- #hide+module GHC.TopHandler (+   runMainIO, runIO, runIOFastExit, runNonIO,+   topHandler, topHandlerFastExit,+   reportStackOverflow, reportError,+  ) 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.Num+import GHC.Real+import GHC.Handle+import GHC.IOBase+import GHC.Weak+import Data.Typeable+#if defined(mingw32_HOST_OS)+import GHC.ConsoleHandler+#endif++-- | '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+      install_interrupt_handler $ do+           m <- deRefWeak weak_tid +           case m of+               Nothing  -> return ()+               Just tid -> throwTo tid (toException UserInterrupt)+      a <- main+      cleanUp+      return a+    `catch`+      topHandler++install_interrupt_handler :: IO () -> IO ()+#ifdef 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 "Signals.h"+-- specialised version of System.Posix.Signals.installHandler, which+-- isn't available here.+install_interrupt_handler handler = do+   let sig = CONST_SIGINT :: CInt+   withSignalHandlerLock $+     alloca $ \p_sp -> do+       sptr <- newStablePtr handler+       poke p_sp sptr+       stg_sig_install sig STG_SIG_RST p_sp nullPtr+       return ()++withSignalHandlerLock :: IO () -> IO ()+withSignalHandlerLock io+ = block $ do+       takeMVar signalHandlerLock+       catchAny (unblock io) (\e -> do putMVar signalHandlerLock (); throw e)+       putMVar signalHandlerLock ()++foreign import ccall unsafe+  stg_sig_install+	:: CInt				-- sig no.+	-> CInt				-- action code (STG_SIG_HAN etc.)+	-> Ptr (StablePtr (IO ()))	-- (in, out) Haskell handler+	-> Ptr ()			-- (in, out) blocked+	-> IO CInt			-- (ret) action code+#endif++-- make a weak pointer to a ThreadId: holding the weak pointer doesn't+-- keep the thread alive and prevent it from being identified as+-- deadlocked.  Vitally important for the main thread.+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->+   case mkWeak# t# t (unsafeCoerce# 0#) s of +      (# s1, w #) -> (# s1, Weak w #)++-- | '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@(SomeException exn) =+  cleanUp >>+  case cast exn of+      Just StackOverflow -> do+           reportStackOverflow+           exit 2++      Just UserInterrupt  -> exitInterrupted++      _ -> case cast exn of+           -- only the main thread gets ExitException exceptions+           Just ExitSuccess     -> exit 0+           Just (ExitFailure n) -> exit n++           _ -> do reportError se+                   exit 1+           ++-- 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).+cleanUp :: IO ()+cleanUp = do+  hFlush stdout `catchAny` \_ -> return ()+  hFlush stderr `catchAny` \_ -> return ()++-- we have to use unsafeCoerce# to get the 'IO a' result type, since the+-- compiler doesn't let us declare that as the result type of a foreign export.+safeExit :: Int -> IO a+safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)++exitInterrupted :: IO a+exitInterrupted = +#ifdef 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)+  unsafeCoerce# (shutdownHaskellAndSignal CONST_SIGINT)++foreign import ccall "shutdownHaskellAndSignal"+  shutdownHaskellAndSignal :: CInt -> IO ()+#endif++-- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*+-- re-enter Haskell land through finalizers.+foreign import ccall "Rts.h shutdownHaskellAndExit"+  shutdownHaskellAndExit :: CInt -> IO ()++fastExit :: Int -> IO a+fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))++foreign import ccall "Rts.h stg_exit"+  stg_exit :: CInt -> IO ()+\end{code}
GHC/Unicode.hs view
@@ -1,2 +1,223 @@-module GHC.Unicode (module X___) where-import "base" GHC.Unicode as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS -#include "WCsubst.h" #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Unicode (+    isAscii, isLatin1, isControl,+    isAsciiUpper, isAsciiLower,+    isPrint, isSpace,  isUpper,+    isLower, isAlpha,  isDigit,+    isOctDigit, isHexDigit, isAlphaNum,+    toUpper, toLower, toTitle,+    wgencat,+  ) where++import GHC.Base+import GHC.Real        (fromIntegral)+import Foreign.C.Types (CInt)+import GHC.Num         (fromInteger)++#include "HsBaseConfig.h"++-- | 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++-- | Selects white-space characters in the Latin-1 range.+-- (In Unicode terms, this includes spaces and some control characters.)+isSpace                 :: Char -> Bool+-- isSpace includes non-breaking space+-- Done with explicit equalities both for efficiency, and to avoid a tiresome+-- recursion with GHC.List elem+isSpace c               =  c == ' '     ||+                           c == '\t'    ||+                           c == '\n'    ||+                           c == '\r'    ||+                           c == '\f'    ||+                           c == '\v'    ||+                           c == '\xa0'  ||+                           iswspace (fromIntegral (ord c)) /= 0++-- | 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 digit Unicode characters.+--+-- Note that numeric digits outside the ASCII range are selected by this+-- function but not by 'isDigit'.  Such digits may be part of identifiers+-- but are not used by the printer and reader to represent numbers.+isAlphaNum              :: Char -> Bool++-- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@.+isDigit                 :: Char -> Bool+isDigit c               =  c >= '0' && c <= '9'++-- | Selects ASCII octal digits, i.e. @\'0\'@..@\'7\'@.+isOctDigit              :: Char -> Bool+isOctDigit c            =  c >= '0' && c <= '7'++-- | Selects ASCII hexadecimal digits,+-- i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@.+isHexDigit              :: Char -> Bool+isHexDigit c            =  isDigit c || c >= 'A' && c <= 'F' ||+                                        c >= 'a' && c <= 'f'++-- | 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 (default)++#if 1++-- Regardless of the O/S and Library, use the functions contained in WCsubst.c++isAlpha    c = iswalpha (fromIntegral (ord c)) /= 0+isAlphaNum c = iswalnum (fromIntegral (ord c)) /= 0+--isSpace    c = iswspace (fromIntegral (ord c)) /= 0+isControl  c = iswcntrl (fromIntegral (ord c)) /= 0+isPrint    c = iswprint (fromIntegral (ord c)) /= 0+isUpper    c = iswupper (fromIntegral (ord c)) /= 0+isLower    c = iswlower (fromIntegral (ord c)) /= 0++toLower c = chr (fromIntegral (towlower (fromIntegral (ord c))))+toUpper c = chr (fromIntegral (towupper (fromIntegral (ord c))))+toTitle c = chr (fromIntegral (towtitle (fromIntegral (ord c))))++foreign import ccall unsafe "u_iswalpha"+  iswalpha :: CInt -> CInt++foreign import ccall unsafe "u_iswalnum"+  iswalnum :: CInt -> CInt++foreign import ccall unsafe "u_iswcntrl"+  iswcntrl :: CInt -> CInt++foreign import ccall unsafe "u_iswspace"+  iswspace :: CInt -> CInt++foreign import ccall unsafe "u_iswprint"+  iswprint :: CInt -> CInt++foreign import ccall unsafe "u_iswlower"+  iswlower :: CInt -> CInt++foreign import ccall unsafe "u_iswupper"+  iswupper :: CInt -> CInt++foreign import ccall unsafe "u_towlower"+  towlower :: CInt -> CInt++foreign import ccall unsafe "u_towupper"+  towupper :: CInt -> CInt++foreign import ccall unsafe "u_towtitle"+  towtitle :: CInt -> CInt++foreign import ccall unsafe "u_gencat"+  wgencat :: CInt -> CInt++-- -----------------------------------------------------------------------------+-- No libunicode, so fall back to the ASCII-only implementation (never used, indeed)++#else++isControl c             =  c < ' ' || c >= '\DEL' && c <= '\x9f'+isPrint c               =  not (isControl c)++-- The upper case ISO characters have the multiplication sign dumped+-- randomly in the middle of the range.  Go figure.+isUpper c               =  c >= 'A' && c <= 'Z' ||+                           c >= '\xC0' && c <= '\xD6' ||+                           c >= '\xD8' && c <= '\xDE'+-- The lower case ISO characters have the division sign dumped+-- randomly in the middle of the range.  Go figure.+isLower c               =  c >= 'a' && c <= 'z' ||+                           c >= '\xDF' && c <= '\xF6' ||+                           c >= '\xF8' && c <= '\xFF'++isAlpha c               =  isLower c || isUpper c+isAlphaNum c            =  isAlpha c || isDigit c++-- Case-changing operations++toUpper c@(C# c#)+  | isAsciiLower c    = C# (chr# (ord# c# -# 32#))+  | isAscii c         = c+    -- fall-through to the slower stuff.+  | isLower c   && c /= '\xDF' && c /= '\xFF'+  = unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A')+  | otherwise+  = c+++toLower c@(C# c#)+  | isAsciiUpper c = C# (chr# (ord# c# +# 32#))+  | isAscii c      = c+  | isUpper c      = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')+  | otherwise      =  c++#endif+
+ GHC/Unicode.hs-boot view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module GHC.Unicode where++import GHC.Bool+import GHC.Types++isAscii         :: Char -> Bool+isLatin1        :: Char -> Bool+isControl       :: Char -> Bool+isPrint         :: Char -> Bool+isSpace         :: Char -> Bool+isUpper         :: Char -> Bool+isLower         :: Char -> Bool+isAlpha         :: Char -> Bool+isDigit         :: Char -> Bool+isOctDigit      :: Char -> Bool+isHexDigit      :: Char -> Bool+isAlphaNum      :: Char -> Bool
− GHC/Weak.hs 
@@ -1,2 +0,0 @@-module GHC.Weak (module X___) where-import "base" GHC.Weak as X___
+ GHC/Weak.lhs view
@@ -0,0 +1,134 @@+\begin{code}+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++-- #hide+module GHC.Weak where++import GHC.Base+import Data.Maybe+import GHC.IOBase       ( IO(..), unIO )+import Data.Typeable++{-|+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 finalisers.++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.+-}+data Weak v = Weak (Weak# v)++#include "Typeable.h"+INSTANCE_TYPEABLE1(Weak,weakTc,"Weak")++-- | 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 finalizer) = IO $ \s ->+   case mkWeak# key val finalizer s of { (# s1, w #) -> (# s1, Weak w #) }+mkWeak key val Nothing = IO $ \s ->+   case mkWeak# key val (unsafeCoerce# 0#) 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 finaliser+        (# 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# (IO ()) -> IO ()+runFinalizerBatch (I# n) arr = +   let  go m  = IO $ \s ->+                  case m of +                  0# -> (# s, () #)+                  _  -> let m' = m -# 1# in+                        case indexArray# arr m' of { (# io #) -> +                        case unIO io s of          { (# s', _ #) -> +                        unIO (go m') s'+                        }}+   in+        go n++\end{code}
GHC/Word.hs view
@@ -1,2 +1,872 @@-module GHC.Word (module X___) where-import "base" GHC.Word as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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"++-- #hide+module GHC.Word (+    Word(..), Word8(..), Word16(..), Word32(..), Word64(..),+    toEnumError, fromEnumError, succError, predError,+    uncheckedShiftL64#,+    uncheckedShiftRL64#+    ) where++import Data.Bits++#if WORD_SIZE_IN_BITS < 32+import GHC.IntWord32+#endif+#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif++import GHC.Base+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Read+import GHC.Arr+import GHC.Show++------------------------------------------------------------------------+-- Helper functions+------------------------------------------------------------------------++{-# NOINLINE toEnumError #-}+toEnumError :: (Show a) => String -> Int -> (a,a) -> b+toEnumError inst_ty i bnds =+    error $ "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 =+    error $ "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 =+    error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"++{-# NOINLINE predError #-}+predError :: String -> a+predError inst_ty =+    error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"++------------------------------------------------------------------------+-- type Word+------------------------------------------------------------------------++-- |A 'Word' is an unsigned integral type, with the same size as 'Int'.+data Word = W# Word# deriving (Eq, Ord)++instance Show Word where+    showsPrec p x = showsPrec p (toInteger x)++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)++instance Real Word where+    toRational x = toInteger x % 1++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 <= fromIntegral (maxBound::Int)+                        = I# (word2Int# x#)+        | otherwise     = fromEnumError "Word" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++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                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))+        | otherwise             = divZeroError+    divMod  (W# x#) y@(W# y#)+        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))+        | otherwise             = divZeroError+    toInteger (W# x#)+        | i# >=# 0#             = smallInteger i#+        | otherwise             = wordToInteger x#+        where+        i# = word2Int# x#++instance Bounded Word where+    minBound = 0++    -- use unboxed literals for maxBound, because GHC doesn't optimise+    -- (fromInteger 0xffffffff :: Word).+#if WORD_SIZE_IN_BITS == 31+    maxBound = W# (int2Word# 0x7FFFFFFF#)+#elif WORD_SIZE_IN_BITS == 32+    maxBound = W# (int2Word# 0xFFFFFFFF#)+#else+    maxBound = W# (int2Word# 0xFFFFFFFFFFFFFFFF#)+#endif++instance Ix Word where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]++instance Bits Word where+    {-# INLINE shift #-}++    (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# (x# `xor#` mb#) where W# mb# = maxBound+    (W# x#) `shift` (I# i#)+        | i# >=# 0#          = W# (x# `shiftL#` i#)+        | otherwise          = W# (x# `shiftRL#` negateInt# i#)+    (W# x#) `rotate` (I# i#)+        | i'# ==# 0# = W# x#+        | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#))+        wsib = WORD_SIZE_IN_BITS#  {- work around preprocessor problem (??) -}+    bitSize  _               = WORD_SIZE_IN_BITS+    isSigned _               = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int->Word"  fromIntegral = \(I# x#) -> W# (int2Word# x#)+"fromIntegral/Word->Int"  fromIntegral = \(W# x#) -> I# (word2Int# x#)+"fromIntegral/Word->Word" fromIntegral = id :: Word -> Word+  #-}++------------------------------------------------------------------------+-- 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 Word8 = W8# Word# deriving (Eq, Ord)+-- ^ 8-bit unsigned integer type++instance Show Word8 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Word8 where+    (W8# x#) + (W8# y#)    = W8# (narrow8Word# (x# `plusWord#` y#))+    (W8# x#) - (W8# y#)    = W8# (narrow8Word# (x# `minusWord#` y#))+    (W8# x#) * (W8# y#)    = W8# (narrow8Word# (x# `timesWord#` y#))+    negate (W8# x#)        = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#))))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W8# (narrow8Word# (integerToWord i))++instance Real Word8 where+    toRational x = toInteger x % 1++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# (int2Word# i#)+        | otherwise     = toEnumError "Word8" i (minBound::Word8, maxBound::Word8)+    fromEnum (W8# x#)   = I# (word2Int# x#)+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Word8 where+    quot    (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `quotWord#` y#)+        | otherwise               = divZeroError+    rem     (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `remWord#` y#)+        | otherwise               = divZeroError+    div     (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `quotWord#` y#)+        | otherwise               = divZeroError+    mod     (W8# x#) y@(W8# y#)+        | y /= 0                  = W8# (x# `remWord#` y#)+        | otherwise               = divZeroError+    quotRem (W8# x#) y@(W8# y#)+        | y /= 0                  = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))+        | otherwise               = divZeroError+    divMod  (W8# x#) y@(W8# y#)+        | y /= 0                  = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))+        | otherwise               = divZeroError+    toInteger (W8# x#)            = smallInteger (word2Int# x#)++instance Bounded Word8 where+    minBound = 0+    maxBound = 0xFF++instance Ix Word8 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word8 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Word8 where+    {-# INLINE shift #-}++    (W8# x#) .&.   (W8# y#)   = W8# (x# `and#` y#)+    (W8# x#) .|.   (W8# y#)   = W8# (x# `or#`  y#)+    (W8# x#) `xor` (W8# y#)   = W8# (x# `xor#` y#)+    complement (W8# x#)       = W8# (x# `xor#` mb#) where W8# mb# = maxBound+    (W8# x#) `shift` (I# i#)+        | i# >=# 0#           = W8# (narrow8Word# (x# `shiftL#` i#))+        | otherwise           = W8# (x# `shiftRL#` negateInt# i#)+    (W8# x#) `rotate` (I# i#)+        | i'# ==# 0# = W8# x#+        | otherwise  = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                          (x# `uncheckedShiftRL#` (8# -# i'#))))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)+    bitSize  _                = 8+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Word8"   fromIntegral = id :: Word8 -> Word8+"fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer+"fromIntegral/a->Word8"       fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#)+"fromIntegral/Word8->a"       fromIntegral = \(W8# x#) -> fromIntegral (W# x#)+  #-}++------------------------------------------------------------------------+-- 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 Word16 = W16# Word# deriving (Eq, Ord)+-- ^ 16-bit unsigned integer type++instance Show Word16 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Word16 where+    (W16# x#) + (W16# y#)  = W16# (narrow16Word# (x# `plusWord#` y#))+    (W16# x#) - (W16# y#)  = W16# (narrow16Word# (x# `minusWord#` y#))+    (W16# x#) * (W16# y#)  = W16# (narrow16Word# (x# `timesWord#` y#))+    negate (W16# x#)       = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#))))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W16# (narrow16Word# (integerToWord i))++instance Real Word16 where+    toRational x = toInteger x % 1++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# (int2Word# i#)+        | otherwise     = toEnumError "Word16" i (minBound::Word16, maxBound::Word16)+    fromEnum (W16# x#)  = I# (word2Int# x#)+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Word16 where+    quot    (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    rem     (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    div     (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    mod     (W16# x#) y@(W16# y#)+        | y /= 0                    = W16# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    quotRem (W16# x#) y@(W16# y#)+        | y /= 0                    = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    divMod  (W16# x#) y@(W16# y#)+        | y /= 0                    = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    toInteger (W16# x#)             = smallInteger (word2Int# x#)++instance Bounded Word16 where+    minBound = 0+    maxBound = 0xFFFF++instance Ix Word16 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word16 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Word16 where+    {-# INLINE shift #-}++    (W16# x#) .&.   (W16# y#)  = W16# (x# `and#` y#)+    (W16# x#) .|.   (W16# y#)  = W16# (x# `or#`  y#)+    (W16# x#) `xor` (W16# y#)  = W16# (x# `xor#` y#)+    complement (W16# x#)       = W16# (x# `xor#` mb#) where W16# mb# = maxBound+    (W16# x#) `shift` (I# i#)+        | i# >=# 0#            = W16# (narrow16Word# (x# `shiftL#` i#))+        | otherwise            = W16# (x# `shiftRL#` negateInt# i#)+    (W16# x#) `rotate` (I# i#)+        | i'# ==# 0# = W16# x#+        | otherwise  = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (16# -# i'#))))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 15#)+    bitSize  _                = 16+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Word16"   fromIntegral = \(W8# x#) -> W16# x#+"fromIntegral/Word16->Word16"  fromIntegral = id :: Word16 -> Word16+"fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer+"fromIntegral/a->Word16"       fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#)+"fromIntegral/Word16->a"       fromIntegral = \(W16# x#) -> fromIntegral (W# x#)+  #-}++------------------------------------------------------------------------+-- type Word32+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 32++data Word32 = W32# Word32#+-- ^ 32-bit unsigned integer type++instance Eq Word32 where+    (W32# x#) == (W32# y#) = x# `eqWord32#` y#+    (W32# x#) /= (W32# y#) = x# `neWord32#` y#++instance Ord Word32 where+    (W32# x#) <  (W32# y#) = x# `ltWord32#` y#+    (W32# x#) <= (W32# y#) = x# `leWord32#` y#+    (W32# x#) >  (W32# y#) = x# `gtWord32#` y#+    (W32# x#) >= (W32# y#) = x# `geWord32#` y#++instance Num Word32 where+    (W32# x#) + (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#))+    (W32# x#) - (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#))+    (W32# x#) * (W32# y#)  = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#))+    negate (W32# x#)       = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#)))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger (S# i#)    = W32# (int32ToWord32# (intToInt32# i#))+    fromInteger (J# s# d#) = W32# (integerToWord32# s# d#)++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        = W32# (wordToWord32# (int2Word# i#))+        | otherwise     = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)+    fromEnum x@(W32# x#)+        | x <= fromIntegral (maxBound::Int)+                        = I# (word2Int# (word32ToWord# x#))+        | otherwise     = fromEnumError "Word32" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++instance Integral Word32 where+    quot    x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord32#` y#)+        | otherwise                 = divZeroError+    rem     x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord32#` y#)+        | otherwise                 = divZeroError+    div     x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord32#` y#)+        | otherwise                 = divZeroError+    mod     x@(W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord32#` y#)+        | otherwise                 = divZeroError+    quotRem x@(W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))+        | otherwise                 = divZeroError+    divMod  x@(W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#))+        | otherwise                 = divZeroError+    toInteger x@(W32# x#)+        | x <= fromIntegral (maxBound::Int)  = S# (word2Int# (word32ToWord# x#))+        | otherwise                 = case word32ToInteger# x# of (# s, d #) -> J# s d++instance Bits Word32 where+    {-# INLINE shift #-}++    (W32# x#) .&.   (W32# y#)  = W32# (x# `and32#` y#)+    (W32# x#) .|.   (W32# y#)  = W32# (x# `or32#`  y#)+    (W32# x#) `xor` (W32# y#)  = W32# (x# `xor32#` y#)+    complement (W32# x#)       = W32# (not32# x#)+    (W32# x#) `shift` (I# i#)+        | i# >=# 0#            = W32# (x# `shiftL32#` i#)+        | otherwise            = W32# (x# `shiftRL32#` negateInt# i#)+    (W32# x#) `rotate` (I# i#)+        | i'# ==# 0# = W32# x#+        | otherwise  = W32# ((x# `shiftL32#` i'#) `or32#`+                             (x# `shiftRL32#` (32# -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                = 32+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Int->Word32"    fromIntegral = \(I#   x#) -> W32# (int32ToWord32# (intToInt32# x#))+"fromIntegral/Word->Word32"   fromIntegral = \(W#   x#) -> W32# (wordToWord32# x#)+"fromIntegral/Word32->Int"    fromIntegral = \(W32# x#) -> I#   (word2Int# (word32ToWord# x#))+"fromIntegral/Word32->Word"   fromIntegral = \(W32# x#) -> W#   (word32ToWord# x#)+"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32+  #-}++#else ++-- 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.+#endif++data Word32 = W32# Word# deriving (Eq, Ord)+-- ^ 32-bit unsigned integer type++instance Num Word32 where+    (W32# x#) + (W32# y#)  = W32# (narrow32Word# (x# `plusWord#` y#))+    (W32# x#) - (W32# y#)  = W32# (narrow32Word# (x# `minusWord#` y#))+    (W32# x#) * (W32# y#)  = W32# (narrow32Word# (x# `timesWord#` y#))+    negate (W32# x#)       = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#))))+    abs x                  = x+    signum 0               = 0+    signum _               = 1+    fromInteger i          = W32# (narrow32Word# (integerToWord i))++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# (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# x#)+        | otherwise     = fromEnumError "Word32" x+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo+#else+    fromEnum (W32# x#)  = I# (word2Int# x#)+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen+#endif++instance Integral Word32 where+    quot    (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    rem     (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    div     (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `quotWord#` y#)+        | otherwise                 = divZeroError+    mod     (W32# x#) y@(W32# y#)+        | y /= 0                    = W32# (x# `remWord#` y#)+        | otherwise                 = divZeroError+    quotRem (W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    divMod  (W32# x#) y@(W32# y#)+        | y /= 0                    = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    toInteger (W32# x#)+#if WORD_SIZE_IN_BITS == 32+        | i# >=# 0#                 = smallInteger i#+        | otherwise                 = wordToInteger x#+        where+        i# = word2Int# x#+#else+                                    = smallInteger (word2Int# x#)+#endif++instance Bits Word32 where+    {-# INLINE shift #-}++    (W32# x#) .&.   (W32# y#)  = W32# (x# `and#` y#)+    (W32# x#) .|.   (W32# y#)  = W32# (x# `or#`  y#)+    (W32# x#) `xor` (W32# y#)  = W32# (x# `xor#` y#)+    complement (W32# x#)       = W32# (x# `xor#` mb#) where W32# mb# = maxBound+    (W32# x#) `shift` (I# i#)+        | i# >=# 0#            = W32# (narrow32Word# (x# `shiftL#` i#))+        | otherwise            = W32# (x# `shiftRL#` negateInt# i#)+    (W32# x#) `rotate` (I# i#)+        | i'# ==# 0# = W32# x#+        | otherwise  = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (32# -# i'#))))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)+    bitSize  _                = 32+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/Word8->Word32"   fromIntegral = \(W8# x#) -> W32# x#+"fromIntegral/Word16->Word32"  fromIntegral = \(W16# x#) -> W32# x#+"fromIntegral/Word32->Word32"  fromIntegral = id :: Word32 -> Word32+"fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer+"fromIntegral/a->Word32"       fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#)+"fromIntegral/Word32->a"       fromIntegral = \(W32# x#) -> fromIntegral (W# x#)+  #-}++#endif++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+++instance Real Word32 where+    toRational x = toInteger x % 1++instance Bounded Word32 where+    minBound = 0+    maxBound = 0xFFFFFFFF++instance Ix Word32 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++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++------------------------------------------------------------------------+-- type Word64+------------------------------------------------------------------------++#if WORD_SIZE_IN_BITS < 64++data Word64 = W64# Word64#+-- ^ 64-bit unsigned integer type++instance Eq Word64 where+    (W64# x#) == (W64# y#) = x# `eqWord64#` y#+    (W64# x#) /= (W64# y#) = x# `neWord64#` y#++instance Ord Word64 where+    (W64# x#) <  (W64# y#) = x# `ltWord64#` y#+    (W64# x#) <= (W64# y#) = x# `leWord64#` y#+    (W64# x#) >  (W64# y#) = x# `gtWord64#` y#+    (W64# x#) >= (W64# y#) = x# `geWord64#` y#++instance Num Word64 where+    (W64# x#) + (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#))+    (W64# x#) - (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `minusInt64#` word64ToInt64# y#))+    (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)++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+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++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#)             = word64ToInteger x#++instance Bits Word64 where+    {-# INLINE shift #-}++    (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#)+        | i# >=# 0#            = W64# (x# `shiftL64#` i#)+        | otherwise            = W64# (x# `shiftRL64#` negateInt# i#)+    (W64# x#) `rotate` (I# i#)+        | i'# ==# 0# = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftL64#` i'#) `or64#`+                             (x# `uncheckedShiftRL64#` (64# -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                = 64+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++-- 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  | b >=# 64#  = wordToWord64# (int2Word# 0#)+                 | otherwise  = a `uncheckedShiftL64#` b++a `shiftRL64#` b | b >=# 64#  = wordToWord64# (int2Word# 0#)+                 | otherwise  = a `uncheckedShiftRL64#` b++{-# RULES+"fromIntegral/Int->Word64"    fromIntegral = \(I#   x#) -> W64# (int64ToWord64# (intToInt64# x#))+"fromIntegral/Word->Word64"   fromIntegral = \(W#   x#) -> W64# (wordToWord64# x#)+"fromIntegral/Word64->Int"    fromIntegral = \(W64# x#) -> I#   (word2Int# (word64ToWord# x#))+"fromIntegral/Word64->Word"   fromIntegral = \(W64# x#) -> W#   (word64ToWord# x#)+"fromIntegral/Word64->Word64" fromIntegral = id :: Word64 -> Word64+  #-}++#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 Word64 = W64# Word# deriving (Eq, Ord)+-- ^ 64-bit unsigned integer type++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)++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+    enumFrom            = integralEnumFrom+    enumFromThen        = integralEnumFromThen+    enumFromTo          = integralEnumFromTo+    enumFromThenTo      = integralEnumFromThenTo++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                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    divMod  (W64# x#) y@(W64# y#)+        | y /= 0                    = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))+        | otherwise                 = divZeroError+    toInteger (W64# x#)+        | i# >=# 0#                 = smallInteger i#+        | otherwise                 = wordToInteger x#+        where+        i# = word2Int# x#++instance Bits Word64 where+    {-# INLINE shift #-}++    (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# (x# `xor#` mb#) where W64# mb# = maxBound+    (W64# x#) `shift` (I# i#)+        | i# >=# 0#            = W64# (x# `shiftL#` i#)+        | otherwise            = W64# (x# `shiftRL#` negateInt# i#)+    (W64# x#) `rotate` (I# i#)+        | i'# ==# 0# = W64# x#+        | otherwise  = W64# ((x# `uncheckedShiftL#` i'#) `or#`+                             (x# `uncheckedShiftRL#` (64# -# i'#)))+        where+        i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)+    bitSize  _                = 64+    isSigned _                = False++    {-# INLINE shiftR #-}+    -- same as the default definition, but we want it inlined (#2376)+    x `shiftR`  i = x `shift`  (-i)++{-# RULES+"fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x#+"fromIntegral/Word64->a" fromIntegral = \(W64# x#) -> fromIntegral (W# x#)+  #-}++uncheckedShiftL64# :: Word# -> Int# -> Word#+uncheckedShiftL64#  = uncheckedShiftL#++uncheckedShiftRL64# :: Word# -> Int# -> Word#+uncheckedShiftRL64# = uncheckedShiftRL#++#endif++instance Show Word64 where+    showsPrec p x = showsPrec p (toInteger x)++instance Real Word64 where+    toRational x = toInteger x % 1++instance Bounded Word64 where+    minBound = 0+    maxBound = 0xFFFFFFFFFFFFFFFF++instance Ix Word64 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral (i - m)+    inRange (m,n) i     = m <= i && i <= n++instance Read Word64 where+    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
Numeric.hs view
@@ -1,2 +1,219 @@-module Numeric (module X___) where-import "base" Numeric as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,       -- :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS++        showIntAtBase,    -- :: Integral a => a -> (a -> Char) -> a -> ShowS+        showInt,          -- :: Integral a => a -> ShowS+        showHex,          -- :: Integral a => a -> ShowS+        showOct,          -- :: Integral a => a -> ShowS++        showEFloat,       -- :: (RealFloat a) => Maybe Int -> a -> ShowS+        showFFloat,       -- :: (RealFloat a) => Maybe Int -> a -> ShowS+        showGFloat,       -- :: (RealFloat a) => Maybe Int -> a -> ShowS+        showFloat,        -- :: (RealFloat a) => a -> ShowS++        floatToDigits,    -- :: (RealFloat a) => Integer -> a -> ([Int], Int)++        -- * Reading++        -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase',+        -- and 'readDec' is the \`dual\' of 'showInt'.+        -- The inconsistent naming is a historical accident.++        readSigned,       -- :: (Real a) => ReadS a -> ReadS a++        readInt,          -- :: (Integral a) => a -> (Char -> Bool)+                          --         -> (Char -> Int) -> ReadS a+        readDec,          -- :: (Integral a) => ReadS a+        readOct,          -- :: (Integral a) => ReadS a+        readHex,          -- :: (Integral a) => ReadS a++        readFloat,        -- :: (RealFloat a) => ReadS a++        lexDigits,        -- :: ReadS String++        -- * Miscellaneous++        fromRat,          -- :: (RealFloat a) => Rational -> a++        ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Read+import GHC.Real+import GHC.Float+import GHC.Num+import GHC.Show+import Data.Maybe+import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail )+import qualified Text.Read.Lex as L+#else+import Data.Char+#endif++#ifdef __HUGS__+import Hugs.Prelude+import Hugs.Numeric+#endif++#ifdef __GLASGOW_HASKELL__+-- -----------------------------------------------------------------------------+-- 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 octal notation.+readOct :: Num a => ReadS a+readOct = readP_to_S L.readOctP++-- | Read an unsigned number in decimal notation.+readDec :: 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 :: 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.Rat y  -> return (fromRational y)+       L.Int i  -> return (fromInteger i)+       _        -> 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    = error "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)+#endif  /* __GLASGOW_HASKELL__ */++-- ---------------------------------------------------------------------------+-- 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 => a -> (Int -> Char) -> a -> ShowS+showIntAtBase base toChr n0 r0+  | base <= 1 = error ("Numeric.showIntAtBase: applied to unsupported base " ++ show base)+  | n0 <  0   = error ("Numeric.showIntAtBase: applied to negative number " ++ show n0)+  | 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 => a -> ShowS+showHex = showIntAtBase 16 intToDigit++-- | Show /non-negative/ 'Integral' numbers in base 8.+showOct :: Integral a => a -> ShowS+showOct = showIntAtBase 8  intToDigit
Prelude.hs view
@@ -1,9 +1,215 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-}-module Prelude-{-# DEPRECATED-      ["You are using the old package `base' version 3.x."-      ,"Future GHC versions will not support base version 3.x. You"-      ,"should update your code to use the new base version 4.x."]-  #-}-  (module X___) where-import "base" Prelude as X___+-----------------------------------------------------------------------------+-- |+-- 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 imported by default into all Haskell+-- modules.  For more documentation, see the Haskell 98 Report+-- <http://www.haskell.org/onlinereport/>.+--+-----------------------------------------------------------------------------++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,++#if defined(__NHC__)+    []((:), []),        -- Not legal Haskell 98;+                        -- ... available through built-in syntax+    module Data.Tuple,  -- Includes tuple types+    ()(..),             -- Not legal Haskell 98+    (->),               -- ... available through built-in syntax+#endif+#ifdef __HUGS__+    (:),                -- Not legal Haskell 98+#endif++    -- ** 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,++    -- *** 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,++    -- ** Monads and functors+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<),++    -- ** Miscellaneous functions+    id, const, (.), flip, ($), until,+    asTypeOf, error, undefined,+    seq, ($!),++    -- * List operations+    map, (++), filter,+    head, last, tail, init, null, length, (!!),+    reverse,+    -- ** Reducing lists (folds)+    foldl, foldl1, foldr, foldr1,+    -- *** Special folds+    and, or, any, all,+    sum, product,+    concat, concatMap,+    maximum, minimum,+    -- ** Building lists+    -- *** Scans+    scanl, scanl1, scanr, scanr1,+    -- *** Infinite lists+    iterate, repeat, replicate, cycle,+    -- ** Sublists+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    -- ** Searching lists+    elem, notElem, lookup,+    -- ** Zipping and unzipping lists+    zip, zip3, zipWith, zipWith3, unzip, unzip3,+    -- ** Functions on strings+    lines, words, unlines, 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, catch++  ) where++#ifndef __HUGS__+import Control.Monad+import System.IO+import Data.List+import Data.Either+import Data.Maybe+import Data.Tuple+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase+import Text.Read+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Float+import GHC.Show+import GHC.Err   ( error, undefined )+#endif++#ifndef __HUGS__+import qualified Control.Exception.Base as New (catch)+#endif++#ifdef __HUGS__+import Hugs.Prelude+#endif++#ifndef __HUGS__+infixr 0 $!++-- -----------------------------------------------------------------------------+-- Miscellaneous functions++-- | Strict (call-by-value) application, defined in terms of 'seq'.+($!)    :: (a -> b) -> a -> b+f $! x  = x `seq` f x+#endif++#ifdef __HADDOCK__+-- | The value of @'seq' a b@ is bottom if @a@ is bottom, and otherwise+-- equal to @b@.  'seq' is usually introduced to improve performance by+-- avoiding unneeded laziness.+seq :: a -> b -> b+seq _ y = y+#endif++#ifndef __HUGS__+-- | The 'catch' function establishes a handler that receives any 'IOError'+-- raised in the action protected by 'catch'.  An 'IOError' is caught by+-- the most recent handler established by 'catch'.  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 = catch 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".+catch :: IO a -> (IOError -> IO a) -> IO a+catch = New.catch+#endif /* !__HUGS__ */
+ Prelude.hs-boot view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++module Prelude where++import GHC.IOBase++catch :: IO a -> (IOError -> IO a) -> IO a
Setup.hs view
@@ -1,2 +1,6 @@+module Main (main) where+ import Distribution.Simple-main = defaultMain++main :: IO ()+main = defaultMainWithHooks defaultUserHooks
− System/CPUTime.hs 
@@ -1,2 +0,0 @@-module System.CPUTime (module X___) where-import "base" System.CPUTime as X___
+ System/CPUTime.hsc view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++module System.CPUTime +        (+         getCPUTime,       -- :: IO Integer+         cpuTimePrecision  -- :: Integer+        ) where++import Prelude++import Data.Ratio++#ifdef __HUGS__+import Hugs.Time ( getCPUTime, clockTicks )+#endif++#ifdef __NHC__+import CPUTime ( getCPUTime, cpuTimePrecision )+#endif++#ifdef __GLASGOW_HASKELL__+import Foreign+import Foreign.C++#include "HsBase.h"+#endif++#ifdef __GLASGOW_HASKELL__+-- -----------------------------------------------------------------------------+-- |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 = do++#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS)+-- getrusage() is right royal pain to deal with when targetting multiple+-- versions of Solaris, since some versions supply it in libc (2.3 and 2.5),+-- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back+-- again in libucb in 2.6..)+--+-- Avoid the problem by resorting to times() instead.+--+#if defined(HAVE_GETRUSAGE) && ! irix_HOST_OS && ! solaris2_HOST_OS+    allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do+    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 CTime+    s_sec  <- (#peek struct timeval,tv_sec)  ru_stime :: IO CTime+    s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime+    let realToInteger = round . realToFrac :: Real a => a -> Integer+    return ((realToInteger u_sec * 1000000 + realToInteger u_usec + +             realToInteger s_sec * 1000000 + realToInteger s_usec) +                * 1000000)++type CRUsage = ()+foreign import ccall unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt+#else+# if defined(HAVE_TIMES)+    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+    let realToInteger = round . realToFrac :: Real a => a -> Integer+    return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000) +                        `div` fromIntegral clockTicks)++type CTms = ()+foreign import ccall unsafe times :: Ptr CTms -> IO CClock+# else+    ioException (IOError Nothing UnsupportedOperation +                         "getCPUTime"+                         "can't get CPU time"+                         Nothing)+# endif+#endif++#else /* win32 */+     -- 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) + (fromIntegral low)) * 100000)++    -- ToDo: pin down elapsed times to just the OS thread(s) that+    -- are evaluating/managing Haskell code.++type FILETIME = ()+type HANDLE = ()+-- need proper Haskell names (initial lower-case character)+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++#endif /* not _WIN32 */+#endif /* __GLASGOW_HASKELL__ */++-- |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.++#ifndef __NHC__+cpuTimePrecision :: Integer+cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))+#endif++#ifdef __GLASGOW_HASKELL__+clockTicks :: Int+clockTicks =+#if defined(CLK_TCK)+    (#const CLK_TCK)+#else+    unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral)+foreign import ccall unsafe sysconf :: CInt -> IO CLong+#endif+#endif /* __GLASGOW_HASKELL__ */
System/Console/GetOpt.hs view
@@ -1,2 +1,393 @@-module System.Console.GetOpt (module X___) where-import "base" System.Console.GetOpt as X___+-----------------------------------------------------------------------------+-- |+-- 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 Prelude -- necessary to get dependencies right++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++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 decription 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 view
@@ -1,2 +1,196 @@-module System.Environment (module X___) where-import "base" System.Environment as X___+-----------------------------------------------------------------------------+-- |+-- 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,       -- :: IO [String]+      getProgName,   -- :: IO String+      getEnv,        -- :: String -> IO String+#ifndef __NHC__+      withArgs,+      withProgName,+#endif+#ifdef __GLASGOW_HASKELL__+      getEnvironment,+#endif+  ) where++import Prelude++#ifdef __GLASGOW_HASKELL__+import Data.List+import Foreign+import Foreign.C+import Control.Exception.Base   ( bracket )+import Control.Monad+import GHC.IOBase+#endif++#ifdef __HUGS__+import Hugs.System+#endif++#ifdef __NHC__+import System+  ( getArgs+  , getProgName+  , getEnv+  )+#endif++-- ---------------------------------------------------------------------------+-- getArgs, getProgName, getEnv++-- | Computation 'getArgs' returns a list of the program's command+-- line arguments (not including the program name).++#ifdef __GLASGOW_HASKELL__+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+   peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString+++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+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+  s <- peekElemOff argv 0 >>= peekCString+  return (basename s)+  where+   basename :: String -> String+   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+#ifdef mingw32_HOST_OS +   isPathSeparator '\\' = True+#endif+   isPathSeparator _    = False+++-- | Computation 'getEnv' @var@ returns the value+-- of the environment variable @var@.  +--+-- This computation may fail with:+--+--  * 'System.IO.Error.isDoesNotExistError' if the environment variable+--    does not exist.++getEnv :: String -> IO String+getEnv name =+    withCString name $ \s -> do+      litstring <- c_getenv s+      if litstring /= nullPtr+        then peekCString litstring+        else ioException (IOError Nothing NoSuchThing "getEnv"+                          "no environment variable" (Just name))++foreign import ccall unsafe "getenv"+   c_getenv :: CString -> IO (Ptr CChar)++{-|+'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 new_args act = do+  pName <- System.Environment.getProgName+  existing_args <- System.Environment.getArgs+  bracket (setArgs new_args)+          (\argv -> do setArgs (pName:existing_args); freeArgv argv)+          (const act)++freeArgv :: Ptr CString -> IO ()+freeArgv argv = do+  size <- lengthArray0 nullPtr argv+  sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]]+  free argv++setArgs :: [String] -> IO (Ptr CString)+setArgs argv = do+  vs <- mapM newCString argv >>= newArray0 nullPtr+  setArgsPrim (genericLength argv) vs+  return vs++foreign import ccall unsafe "setProgArgv" +  setArgsPrim  :: 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)]+getEnvironment = do+   pBlock <- getEnvBlock+   if pBlock == nullPtr then return []+    else do+      stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString+      return (map divvy stuff)+  where+   divvy str =+      case break (=='=') str of+        (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)+        (name,_:value) -> (name,value)++foreign import ccall unsafe "__hscore_environ" +  getEnvBlock :: IO (Ptr CString)+#endif  /* __GLASGOW_HASKELL__ */
System/Exit.hs view
@@ -1,2 +1,81 @@-module System.Exit (module X___) where-import "base" System.Exit as X___+-----------------------------------------------------------------------------+-- |+-- 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      -- :: ExitCode -> IO a+    , exitFailure   -- :: IO a+    , exitSuccess   -- :: IO a+  ) where++import Prelude++#ifdef __GLASGOW_HASKELL__+import GHC.IOBase+#endif++#ifdef __HUGS__+import Hugs.Prelude (ExitCode(..))+import Control.Exception.Base+#endif++#ifdef __NHC__+import System+  ( ExitCode(..)+  , exitWith+  )+#endif++-- ---------------------------------------------------------------------------+-- exitWith++-- | Computation 'exitWith' @code@ throws 'ExitException' @code@.+-- Normally this terminates the program, returning @code@ to the+-- program's caller.  Before the program terminates, any open or+-- semi-closed handles are first closed.+--+-- 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 it it had called 'exitWith' 'ExitSuccess'.+--+-- As an 'ExitException' 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 an 'Exception', 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'.++#ifndef __NHC__+exitWith :: ExitCode -> IO a+exitWith ExitSuccess = throwIO ExitSuccess+exitWith code@(ExitFailure n)+  | n /= 0 = throwIO code+#ifdef __GLASGOW_HASKELL__+  | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)+#endif+#endif  /* ! __NHC__ */++-- | 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+-- sucessfully.+exitSuccess :: IO a+exitSuccess = exitWith ExitSuccess
System/IO.hs view
@@ -1,2 +1,541 @@-module System.IO (module X___) where-import "base" System.IO as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,                        -- instance MonadFix+    fixIO,                     -- :: (a -> IO a) -> IO a++    -- * Files and handles++    FilePath,                  -- :: String++    Handle,             -- abstract, instance of: Eq, Show.++    -- ** Standard handles++    -- | Three handles are allocated during program initialisation,+    -- and are initially open.++    stdin, stdout, stderr,   -- :: Handle++    -- * Opening and closing files++    -- ** Opening files++    withFile,+    openFile,                  -- :: FilePath -> IOMode -> IO Handle+    IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),++    -- ** Closing files++    hClose,                    -- :: Handle -> IO ()++    -- ** Special cases++    -- | These functions are also exported by the "Prelude".++    readFile,                  -- :: FilePath -> IO String+    writeFile,                 -- :: FilePath -> String -> IO ()+    appendFile,                -- :: FilePath -> String -> IO ()++    -- ** File locking++    -- $locking++    -- * Operations on handles++    -- ** Determining and changing the size of a file++    hFileSize,                 -- :: Handle -> IO Integer+#ifdef __GLASGOW_HASKELL__+    hSetFileSize,              -- :: Handle -> Integer -> IO ()+#endif++    -- ** Detecting the end of input++    hIsEOF,                    -- :: Handle -> IO Bool+    isEOF,                     -- :: IO Bool++    -- ** Buffering operations++    BufferMode(NoBuffering,LineBuffering,BlockBuffering),+    hSetBuffering,             -- :: Handle -> BufferMode -> IO ()+    hGetBuffering,             -- :: Handle -> IO BufferMode+    hFlush,                    -- :: Handle -> IO ()++    -- ** Repositioning handles++    hGetPosn,                  -- :: Handle -> IO HandlePosn+    hSetPosn,                  -- :: HandlePosn -> IO ()+    HandlePosn,                -- abstract, instance of: Eq, Show.++    hSeek,                     -- :: Handle -> SeekMode -> Integer -> IO ()+    SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),+#if !defined(__NHC__)+    hTell,                     -- :: Handle -> IO Integer+#endif++    -- ** Handle properties++    hIsOpen, hIsClosed,        -- :: Handle -> IO Bool+    hIsReadable, hIsWritable,  -- :: Handle -> IO Bool+    hIsSeekable,               -- :: Handle -> IO Bool++    -- ** Terminal operations (not portable: GHC\/Hugs only)++#if !defined(__NHC__)+    hIsTerminalDevice,          -- :: Handle -> IO Bool++    hSetEcho,                   -- :: Handle -> Bool -> IO ()+    hGetEcho,                   -- :: Handle -> IO Bool+#endif++    -- ** Showing handle state (not portable: GHC only)++#ifdef __GLASGOW_HASKELL__+    hShow,                      -- :: Handle -> IO String+#endif++    -- * Text input and output++    -- ** Text input++    hWaitForInput,             -- :: Handle -> Int -> IO Bool+    hReady,                    -- :: Handle -> IO Bool+    hGetChar,                  -- :: Handle -> IO Char+    hGetLine,                  -- :: Handle -> IO [Char]+    hLookAhead,                -- :: Handle -> IO Char+    hGetContents,              -- :: Handle -> IO [Char]++    -- ** Text output++    hPutChar,                  -- :: Handle -> Char -> IO ()+    hPutStr,                   -- :: Handle -> [Char] -> IO ()+    hPutStrLn,                 -- :: Handle -> [Char] -> IO ()+    hPrint,                    -- :: Show a => Handle -> a -> IO ()++    -- ** Special cases for standard input and output++    -- | These functions are also exported by the "Prelude".++    interact,                  -- :: (String -> String) -> IO ()+    putChar,                   -- :: Char   -> IO ()+    putStr,                    -- :: String -> IO () +    putStrLn,                  -- :: String -> IO ()+    print,                     -- :: Show a => a -> IO ()+    getChar,                   -- :: IO Char+    getLine,                   -- :: IO String+    getContents,               -- :: IO String+    readIO,                    -- :: Read a => String -> IO a+    readLn,                    -- :: Read a => IO a++    -- * Binary input and output++    withBinaryFile,+    openBinaryFile,            -- :: FilePath -> IOMode -> IO Handle+    hSetBinaryMode,            -- :: Handle -> Bool -> IO ()+    hPutBuf,                   -- :: Handle -> Ptr a -> Int -> IO ()+    hGetBuf,                   -- :: Handle -> Ptr a -> Int -> IO Int+#if !defined(__NHC__) && !defined(__HUGS__)+    hPutBufNonBlocking,        -- :: Handle -> Ptr a -> Int -> IO Int+    hGetBufNonBlocking,        -- :: Handle -> Ptr a -> Int -> IO Int+#endif++    -- * Temporary files++    openTempFile,+    openBinaryTempFile,+  ) where++import Control.Exception.Base++#ifndef __NHC__+import Data.Bits+import Data.List+import Data.Maybe+import Foreign.C.Error+import Foreign.C.String+import Foreign.C.Types+import System.Posix.Internals+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.IOBase       -- Together these four Prelude modules define+import GHC.Handle       -- all the stuff exported by IO for the GHC version+import GHC.IO+import GHC.Exception+import GHC.Num+import Text.Read+import GHC.Show+#endif++#ifdef __HUGS__+import Hugs.IO+import Hugs.IOExts+import Hugs.IORef+import System.IO.Unsafe ( unsafeInterleaveIO )+#endif++#ifdef __NHC__+import IO+  ( Handle ()+  , HandlePosn ()+  , IOMode (ReadMode,WriteMode,AppendMode,ReadWriteMode)+  , BufferMode (NoBuffering,LineBuffering,BlockBuffering)+  , SeekMode (AbsoluteSeek,RelativeSeek,SeekFromEnd)+  , stdin, stdout, stderr+  , openFile                  -- :: FilePath -> IOMode -> IO Handle+  , hClose                    -- :: Handle -> IO ()+  , hFileSize                 -- :: Handle -> IO Integer+  , hIsEOF                    -- :: Handle -> IO Bool+  , isEOF                     -- :: IO Bool+  , hSetBuffering             -- :: Handle -> BufferMode -> IO ()+  , hGetBuffering             -- :: Handle -> IO BufferMode+  , hFlush                    -- :: Handle -> IO ()+  , hGetPosn                  -- :: Handle -> IO HandlePosn+  , hSetPosn                  -- :: HandlePosn -> IO ()+  , hSeek                     -- :: Handle -> SeekMode -> Integer -> IO ()+  , hWaitForInput             -- :: Handle -> Int -> IO Bool+  , hGetChar                  -- :: Handle -> IO Char+  , hGetLine                  -- :: Handle -> IO [Char]+  , hLookAhead                -- :: Handle -> IO Char+  , hGetContents              -- :: Handle -> IO [Char]+  , hPutChar                  -- :: Handle -> Char -> IO ()+  , hPutStr                   -- :: Handle -> [Char] -> IO ()+  , hPutStrLn                 -- :: Handle -> [Char] -> IO ()+  , hPrint                    -- :: Handle -> [Char] -> IO ()+  , hReady                    -- :: Handle -> [Char] -> IO ()+  , hIsOpen, hIsClosed        -- :: Handle -> IO Bool+  , hIsReadable, hIsWritable  -- :: Handle -> IO Bool+  , hIsSeekable               -- :: Handle -> IO Bool+  , bracket++  , IO ()+  , FilePath                  -- :: String+  )+import NHC.IOExtras (fixIO, hPutBuf, hGetBuf)+import NHC.FFI (Ptr)+#endif++-- -----------------------------------------------------------------------------+-- Standard IO++#ifdef __GLASGOW_HASKELL__+-- | 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      =  do putStr s+                      putChar '\n'++-- | 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 '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 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          =  do l <- getLine+                      r <- readIO l+                      return r++-- | 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")+#endif  /* __GLASGOW_HASKELL__ */++#ifndef __NHC__+-- | 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++-- | The same as 'hPutStr', but adds a newline character.++hPutStrLn       :: Handle -> String -> IO ()+hPutStrLn hndl str = do+ hPutStr  hndl str+ hPutChar hndl '\n'++-- | 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+#endif /* !__NHC__ */++-- | @'withFile' name mode act@ opens a file using '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.+withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFile name mode = bracket (openFile name mode) hClose++-- | @'withBinaryFile' name mode act@ opens a file using 'openBinaryFile'+-- and passes the resulting handle to the computation @act@.  The handle+-- will be closed on exit from 'withBinaryFile', whether by normal+-- termination or by raising an exception.+withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withBinaryFile name mode = bracket (openBinaryFile name mode) hClose++-- ---------------------------------------------------------------------------+-- fixIO++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+fixIO :: (a -> IO a) -> IO a+fixIO k = do+    ref <- newIORef (throw NonTermination)+    ans <- unsafeInterleaveIO (readIORef ref)+    result <- k ans+    writeIORef ref result+    return result++-- NOTE: 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.+#endif++#if defined(__NHC__)+-- Assume a unix platform, where text and binary I/O are identical.+openBinaryFile = openFile+hSetBinaryMode _ _ = return ()+#endif++-- | 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 creates 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.+             -> IO (FilePath, Handle)+openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template False++-- | 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++openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)+openTempFile' loc tmp_dir template binary = do+  pid <- c_getpid+  findTempName pid+  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.+         _                      -> error "bug in System.IO.openTempFile"++#ifndef __NHC__+    oflags1 = rw_flags .|. o_EXCL++    binary_flags+      | binary    = o_BINARY+      | otherwise = 0++    oflags = oflags1 .|. binary_flags+#endif++#ifdef __NHC__+    findTempName x = do h <- openFile filepath ReadWriteMode+                        return (filepath, h)+#else+    findTempName x = do+      fd <- withCString filepath $ \ f ->+              c_open f oflags 0o600+      if fd < 0+       then do+         errno <- getErrno+         if errno == eEXIST+           then findTempName (x+1)+           else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))+       else do+         -- XXX We want to tell fdToHandle what the filepath is,+         -- as any exceptions etc will only be able to report the+         -- fd currently+         h <- fdToHandle fd `onException` c_close fd+         return (filepath, h)+#endif+      where+        filename        = prefix ++ show x ++ suffix+        filepath        = tmp_dir `combine` filename++        -- XXX bits copied from System.FilePath, since that's not available here+        combine a b+                  | null b = a+                  | null a = b+                  | last a == pathSeparator = a ++ b+                  | otherwise = a ++ [pathSeparator] ++ b++#if __HUGS__+        fdToHandle fd   = openFd (fromIntegral fd) False ReadWriteMode binary+#endif++-- XXX Should use filepath library+pathSeparator :: Char+#ifdef mingw32_HOST_OS+pathSeparator = '\\'+#else+pathSeparator = '/'+#endif++#ifndef __NHC__+-- XXX Copied from GHC.Handle+std_flags, output_flags, rw_flags :: CInt+std_flags    = o_NONBLOCK   .|. o_NOCTTY+output_flags = std_flags    .|. o_CREAT+rw_flags     = output_flags .|. o_RDWR+#endif++#ifdef __NHC__+foreign import ccall "getpid" c_getpid :: IO Int+#endif++-- $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 view
@@ -1,2 +1,389 @@-module System.IO.Error (module X___) where-import "base" System.IO.Error as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}++-----------------------------------------------------------------------------+-- |+-- 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,                    -- = IOException++    userError,                  -- :: String  -> IOError++#ifndef __NHC__+    mkIOError,                  -- :: IOErrorType -> String -> Maybe Handle+                                --    -> Maybe FilePath -> IOError++    annotateIOError,            -- :: IOError -> String -> Maybe Handle+                                --    -> Maybe FilePath -> IOError+#endif++    -- ** Classifying I\/O errors+    isAlreadyExistsError,       -- :: IOError -> Bool+    isDoesNotExistError,+    isAlreadyInUseError,+    isFullError, +    isEOFError,+    isIllegalOperation, +    isPermissionError,+    isUserError,++    -- ** Attributes of I\/O errors+#ifndef __NHC__+    ioeGetErrorType,            -- :: IOError -> IOErrorType+    ioeGetLocation,             -- :: IOError -> String+#endif+    ioeGetErrorString,          -- :: IOError -> String+    ioeGetHandle,               -- :: IOError -> Maybe Handle+    ioeGetFileName,             -- :: IOError -> Maybe FilePath++#ifndef __NHC__+    ioeSetErrorType,            -- :: IOError -> IOErrorType -> IOError+    ioeSetErrorString,          -- :: IOError -> String -> IOError+    ioeSetLocation,             -- :: IOError -> String -> IOError+    ioeSetHandle,               -- :: IOError -> Handle -> IOError+    ioeSetFileName,             -- :: IOError -> FilePath -> IOError+#endif++    -- * Types of I\/O error+    IOErrorType,                -- abstract++    alreadyExistsErrorType,     -- :: IOErrorType+    doesNotExistErrorType,+    alreadyInUseErrorType,+    fullErrorType,+    eofErrorType,+    illegalOperationErrorType, +    permissionErrorType,+    userErrorType,++    -- ** 'IOErrorType' predicates+    isAlreadyExistsErrorType,   -- :: IOErrorType -> Bool+    isDoesNotExistErrorType,+    isAlreadyInUseErrorType,+    isFullErrorType, +    isEOFErrorType,+    isIllegalOperationErrorType, +    isPermissionErrorType,+    isUserErrorType, ++    -- * Throwing and catching I\/O errors++    ioError,                    -- :: IOError -> IO a++    catch,                      -- :: IO a -> (IOError -> IO a) -> IO a+    try,                        -- :: IO a -> IO (Either IOError a)++#ifndef __NHC__+    modifyIOError,              -- :: (IOError -> IOError) -> IO a -> IO a+#endif+  ) where++#ifndef __HUGS__+import Data.Either+#endif+import Data.Maybe++#ifdef __GLASGOW_HASKELL__+import {-# SOURCE #-} Prelude (catch)++import GHC.Base+import GHC.IOBase+import Text.Show+#endif++#ifdef __HUGS__+import Hugs.Prelude(Handle, IOException(..), IOErrorType(..), IO)+#endif++#ifdef __NHC__+import IO+  ( IOError ()+  , try+  , ioError+  , userError+  , isAlreadyExistsError        -- :: IOError -> Bool+  , isDoesNotExistError+  , isAlreadyInUseError+  , isFullError+  , isEOFError+  , isIllegalOperation+  , isPermissionError+  , isUserError+  , ioeGetErrorString           -- :: IOError -> String+  , ioeGetHandle                -- :: IOError -> Maybe Handle+  , ioeGetFileName              -- :: IOError -> Maybe FilePath+  )+--import Data.Maybe (fromJust)+--import Control.Monad (MonadPlus(mplus))+#endif++-- | The construct 'try' @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".++#ifndef __NHC__+try            :: IO a -> IO (Either IOError a)+try f          =  catch (do r <- f+                            return (Right r))+                        (return . Left)+#endif++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+-- -----------------------------------------------------------------------------+-- 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_handle = maybe_hdl, +                        ioe_filename = maybe_filename+                        }+#ifdef __NHC__+mkIOError EOF       location maybe_hdl maybe_filename =+    EOFError location (fromJust maybe_hdl)+mkIOError UserError location maybe_hdl maybe_filename =+    UserError location ""+mkIOError t         location maybe_hdl maybe_filename =+    NHC.FFI.mkIOError location maybe_filename maybe_handle (ioeTypeToInt t)+  where+    ioeTypeToInt AlreadyExists     = fromEnum EEXIST+    ioeTypeToInt NoSuchThing       = fromEnum ENOENT+    ioeTypeToInt ResourceBusy      = fromEnum EBUSY+    ioeTypeToInt ResourceExhausted = fromEnum ENOSPC+    ioeTypeToInt IllegalOperation  = fromEnum EPERM+    ioeTypeToInt PermissionDenied  = fromEnum EACCES+#endif+#endif /* __GLASGOW_HASKELL__ || __HUGS__ */++#ifndef __NHC__+-- -----------------------------------------------------------------------------+-- 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+#endif /* __NHC__ */++-- -----------------------------------------------------------------------------+-- IOErrorTypes++#ifdef __NHC__+data IOErrorType = AlreadyExists | NoSuchThing | ResourceBusy+                 | ResourceExhausted | EOF | IllegalOperation+                 | PermissionDenied | UserError+#endif++-- | 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++-- -----------------------------------------------------------------------------+-- 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++-- -----------------------------------------------------------------------------+-- Miscellaneous++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+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 (IOError ohdl errTy _ str opath) loc hdl path = +  IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath)+  where+    Nothing `mplus` ys = ys+    xs      `mplus` _  = xs+#endif /* __GLASGOW_HASKELL__ || __HUGS__ */++#if 0 /*__NHC__*/+annotateIOError (IOError msg file hdl code) msg' file' hdl' =+    IOError (msg++'\n':msg') (file`mplus`file') (hdl`mplus`hdl') code+annotateIOError (EOFError msg hdl) msg' file' hdl' =+    EOFError (msg++'\n':msg') (hdl`mplus`hdl')+annotateIOError (UserError loc msg) msg' file' hdl' =+    UserError loc (msg++'\n':msg')+annotateIOError (PatternError loc) msg' file' hdl' =+    PatternError (loc++'\n':msg')+#endif
System/IO/Unsafe.hs view
@@ -1,2 +1,37 @@-module System.IO.Unsafe (module X___) where-import "base" System.IO.Unsafe as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,     -- :: IO a -> a+   unsafeInterleaveIO,  -- :: IO a -> IO a+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.IOBase (unsafePerformIO, unsafeInterleaveIO)+#endif++#ifdef __HUGS__+import Hugs.IOExts (unsafePerformIO, unsafeInterleaveIO)+#endif++#ifdef __NHC__+import NHC.Internal (unsafePerformIO)+#endif++#if !__GLASGOW_HASKELL__ && !__HUGS__+unsafeInterleaveIO :: IO a -> IO a+unsafeInterleaveIO f = return (unsafePerformIO f)+#endif
System/Info.hs view
@@ -1,2 +1,66 @@-module System.Info (module X___) where-import "base" System.Info as X___+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++module System.Info+   (+       os,		    -- :: String+       arch,		    -- :: String+       compilerName,	    -- :: String+       compilerVersion	    -- :: Version+   ) where++import Prelude+import Data.Version++-- | The version of 'compilerName' with which the program was compiled+-- or is being interpreted.+compilerVersion :: Version+compilerVersion = Version {versionBranch=[major, minor], versionTags=[]}+  where (major, minor) = compilerVersionRaw `divMod` 100++-- | The operating system on which the program is running.+os :: String++-- | The machine architecture on which the program is running.+arch :: String++-- | The Haskell implementation with which the program was compiled+-- or is being interpreted.+compilerName :: String++compilerVersionRaw :: Int++#if defined(__NHC__)+#include "OSInfo.hs"+compilerName = "nhc98"+compilerVersionRaw = __NHC__++#elif defined(__GLASGOW_HASKELL__)+#include "ghcplatform.h"+os = HOST_OS+arch = HOST_ARCH+compilerName = "ghc"+compilerVersionRaw = __GLASGOW_HASKELL__++#elif defined(__HUGS__)+#include "platform.h"+os = HOST_OS+arch = HOST_ARCH+compilerName = "hugs"+compilerVersionRaw = 0  -- ToDo++#else+#error Unknown compiler name+#endif
System/Mem.hs view
@@ -1,2 +1,32 @@-module System.Mem (module X___) where-import "base" System.Mem as X___+-----------------------------------------------------------------------------+-- |+-- 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 (+ 	performGC	-- :: IO ()+  ) where+ +import Prelude++#ifdef __HUGS__+import Hugs.IOExts+#endif++#ifdef __GLASGOW_HASKELL__+-- | Triggers an immediate garbage collection+foreign import ccall {-safe-} "performMajorGC" performGC :: IO ()+#endif++#ifdef __NHC__+import NHC.IOExtras (performGC)+#endif
System/Mem/StableName.hs view
@@ -1,2 +1,116 @@-module System.Mem.StableName (module X___) where-import "base" System.Mem.StableName as X___+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Mem.StableName+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Stable names are a way of performing fast (O(1)), not-quite-exact+-- comparison between objects.+-- +-- Stable names solve the following problem: suppose you want to build+-- a hash table with Haskell objects as keys, but you want to use+-- pointer equality for comparison; maybe because the keys are large+-- and hashing would be slow, or perhaps because the keys are infinite+-- in size.  We can\'t build a hash table using the address of the+-- object as the key, because objects get moved around by the garbage+-- collector, meaning a re-hash would be necessary after every garbage+-- collection.+--+-------------------------------------------------------------------------------++module System.Mem.StableName (+  -- * Stable Names+  StableName,+  makeStableName,+  hashStableName,+  ) where++import Prelude++import Data.Typeable++#ifdef __HUGS__+import Hugs.Stable+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.IOBase	( 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 `mkStableName` 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)+#if defined(__PARALLEL_HASKELL__)+makeStableName a = +  error "makeStableName not implemented in parallel Haskell"+#else+makeStableName a = IO $ \ s ->+    case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #)+#endif++-- | Convert a 'StableName' to an 'Int'.  The 'Int' returned is not+-- necessarily unique; several 'StableName's may map to the same 'Int'+-- (in practice however, the chances of this are small, so the result+-- of 'hashStableName' makes a good hash key).+hashStableName :: StableName a -> Int+#if defined(__PARALLEL_HASKELL__)+hashStableName (StableName sn) = +  error "hashStableName not implemented in parallel Haskell"+#else+hashStableName (StableName sn) = I# (stableNameToInt# sn)+#endif++instance Eq (StableName a) where +#if defined(__PARALLEL_HASKELL__)+    (StableName sn1) == (StableName sn2) = +      error "eqStableName not implemented in parallel Haskell"+#else+    (StableName sn1) == (StableName sn2) = +       case eqStableName# sn1 sn2 of+	 0# -> False+	 _  -> True+#endif++#endif /* __GLASGOW_HASKELL__ */++#include "Typeable.h"+INSTANCE_TYPEABLE1(StableName,stableNameTc,"StableName")
System/Mem/Weak.hs view
@@ -1,2 +1,151 @@-module System.Mem.Weak (module X___) where-import "base" System.Mem.Weak as X___+-----------------------------------------------------------------------------+-- |+-- 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,      		-- :: k -> v -> Maybe (IO ()) -> IO (Weak v)+	deRefWeak, 		-- :: Weak v -> IO (Maybe v)+	finalize,		-- :: Weak v -> IO ()++	-- * Specialised versions+	mkWeakPtr, 		-- :: k -> Maybe (IO ()) -> IO (Weak k)+	addFinalizer, 		-- :: key -> IO () -> IO ()+	mkWeakPair, 		-- :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))+	-- replaceFinaliser	-- :: Weak v -> IO () -> IO ()++	-- * A precise semantics+	+	-- $precise+   ) where++import Prelude++#ifdef __HUGS__+import Hugs.Weak+#endif++#ifdef __GLASGOW_HASKELL__+import GHC.Weak+#endif++-- | 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 as well as using the specialised version+  'Foreign.ForeignPtr.addForeignPtrFinalizer' because the latter+  version adds the finalizer to the primitive 'ForeignPtr#' object+  inside, whereas the generic 'addFinalizer' will add the finalizer to+  the box.  Optimisations tend to remove the box, which may cause the+  finalizer to run earlier than you intended.  The same motivation+  justifies the existence of+  'Control.Concurrent.MVar.addMVarFinalizer' and+  'Data.IORef.mkWeakIORef' (the non-uniformity is accidental).+-}+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 an object whose key is reachable.+-}
System/Posix/Internals.hs view
@@ -1,2 +1,518 @@-module System.Posix.Internals (module X___) where-import "base" System.Posix.Internals as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_HADDOCK hide #-}++-----------------------------------------------------------------------------+-- |+-- 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)+--+-----------------------------------------------------------------------------++-- #hide+module System.Posix.Internals where++#include "HsBaseConfig.h"++#if ! (defined(mingw32_HOST_OS) || defined(__MINGW32__))+import Control.Monad+#endif+import System.Posix.Types++import Foreign+import Foreign.C++import Data.Bits+import Data.Maybe++#if __GLASGOW_HASKELL__+import GHC.Base+import GHC.Num+import GHC.Real+import GHC.IOBase+#elif __HUGS__+import Hugs.Prelude (IOException(..), IOErrorType(..))+import Hugs.IO (IOMode(..))+#else+import System.IO+#endif++#ifdef __HUGS__+{-# CFILES cbits/PrelIOUtils.c cbits/dirUtils.c cbits/consUtils.c #-}+#endif++-- ---------------------------------------------------------------------------+-- Types++type CDir       = ()+type CDirent    = ()+type CFLock     = ()+type CGroup     = ()+type CLconv     = ()+type CPasswd    = ()+type CSigaction = ()+type CSigset    = ()+type CStat      = ()+type CTermios   = ()+type CTm        = ()+type CTms       = ()+type CUtimbuf   = ()+type CUtsname   = ()++#ifndef __GLASGOW_HASKELL__+type FD = CInt+#endif++-- ---------------------------------------------------------------------------+-- 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)++data FDType  = Directory | Stream | RegularFile | RawDevice+               deriving (Eq)++fileType :: FilePath -> IO FDType+fileType file =+  allocaBytes sizeof_stat $ \ p_stat -> do+  withCString 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 (FDType, 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 FDType+fdType fd = do (ty,_,_) <- fdStat fd; return ty++statGetType :: Ptr CStat -> IO FDType+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++#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))+closeFd :: Bool -> CInt -> IO CInt+closeFd isStream fd +  | isStream  = c_closesocket fd+  | otherwise = c_close fd++foreign import stdcall unsafe "HsBase.h closesocket"+   c_closesocket :: CInt -> IO CInt+#endif++fdGetMode :: FD -> IO IOMode+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+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++-- ---------------------------------------------------------------------------+-- Terminal-related stuff++fdIsTTY :: FD -> IO Bool+fdIsTTY fd = c_isatty fd >>= return.toBool++#if defined(HTYPE_TCFLAG_T)++setEcho :: FD -> Bool -> IO ()+setEcho fd on = do+  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 = do+  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 = do+     allocaBytes sizeof_termios  $ \p_tios -> do+        throwErrnoIfMinus1Retry "tcSetAttr"+           (c_tcgetattr fd p_tios)++#ifdef __GLASGOW_HASKELL__+        -- 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+#endif++        -- 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 -> do+        allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do+             c_sigemptyset p_sigset+             c_sigaddset   p_sigset const_sigttou+             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+             c_sigprocmask const_sig_setmask p_old_sigset nullPtr+             return r++#ifdef __GLASGOW_HASKELL__+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 ()+#endif++#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 + = IOError Nothing OtherError loc msg Nothing++-- 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++#endif++-- ---------------------------------------------------------------------------+-- Turning on non-blocking for a file descriptor++setNonBlockingFD :: FD -> IO ()+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+setNonBlockingFD fd = do+  flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"+                 (c_fcntl_read fd const_f_getfl)+  -- 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.+  unless (testBit flags (fromIntegral o_NONBLOCK)) $ do+    c_fcntl_write fd const_f_setfl (fromIntegral (flags .|. o_NONBLOCK))+    return ()+#else++-- bogus defns for win32+setNonBlockingFD _ = return ()++#endif++-- -----------------------------------------------------------------------------+-- foreign imports++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 closedir" +   c_closedir :: Ptr CDir -> 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 __hscore_fstat"+   c_fstat :: CInt -> Ptr CStat -> IO CInt++foreign import ccall unsafe "HsBase.h isatty"+   c_isatty :: CInt -> IO CInt++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+foreign import ccall unsafe "HsBase.h __hscore_lseek"+   c_lseek :: CInt -> Int64 -> CInt -> IO Int64+#else+foreign import ccall unsafe "HsBase.h __hscore_lseek"+   c_lseek :: CInt -> COff -> CInt -> IO COff+#endif++foreign import ccall unsafe "HsBase.h __hscore_lstat"+   lstat :: CString -> Ptr CStat -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_open"+   c_open :: CString -> CInt -> CMode -> IO CInt++foreign import ccall unsafe "HsBase.h opendir" +   c_opendir :: CString  -> IO (Ptr CDir)++foreign import ccall unsafe "HsBase.h __hscore_mkdir"+   mkdir :: CString -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h read" +   c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize++foreign import ccall unsafe "HsBase.h rewinddir"+   c_rewinddir :: Ptr CDir -> IO ()++foreign import ccall unsafe "HsBase.h __hscore_stat"+   c_stat :: CString -> Ptr CStat -> IO CInt++foreign import ccall unsafe "HsBase.h umask"+   c_umask :: CMode -> IO CMode++foreign import ccall unsafe "HsBase.h write" +   c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize++foreign import ccall unsafe "HsBase.h __hscore_ftruncate"+   c_ftruncate :: CInt -> COff -> IO CInt++foreign import ccall unsafe "HsBase.h unlink"+   c_unlink :: CString -> IO CInt++foreign import ccall unsafe "HsBase.h getpid"+   c_getpid :: IO CPid++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+foreign import ccall unsafe "HsBase.h fcntl"+   c_fcntl_read  :: CInt -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h fcntl"+   c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt++foreign import ccall 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++foreign import ccall unsafe "HsBase.h mkfifo"+   c_mkfifo :: CString -> CMode -> IO CInt++foreign import ccall unsafe "HsBase.h pipe"+   c_pipe :: Ptr CInt -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_sigemptyset"+   c_sigemptyset :: Ptr CSigset -> IO CInt++foreign import ccall unsafe "HsBase.h __hscore_sigaddset"+   c_sigaddset :: Ptr CSigset -> CInt -> IO CInt++foreign import ccall unsafe "HsBase.h sigprocmask"+   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt++foreign import ccall unsafe "HsBase.h tcgetattr"+   c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt++foreign import ccall unsafe "HsBase.h tcsetattr"+   c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt++foreign import ccall unsafe "HsBase.h utime"+   c_utime :: CString -> Ptr CUtimbuf -> IO CInt++foreign import ccall unsafe "HsBase.h waitpid"+   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid+#endif++-- traversing directories+foreign import ccall unsafe "dirUtils.h __hscore_readdir"+  readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt+ +foreign import ccall unsafe "HsBase.h __hscore_free_dirent"+  freeDirEnt  :: Ptr CDirent -> IO ()+ +foreign import ccall unsafe "HsBase.h __hscore_end_of_dir"+  end_of_dir :: CInt+ +foreign import ccall unsafe "HsBase.h __hscore_d_name"+  d_name :: Ptr CDirent -> IO CString++-- 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 ccall unsafe "HsBase.h __hscore_s_isreg"  c_s_isreg  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_ischr"  c_s_ischr  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_isblk"  c_s_isblk  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_s_isdir"  c_s_isdir  :: CMode -> CInt+foreign import ccall unsafe "HsBase.h __hscore_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+#ifdef 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++#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) && !defined(__MINGW32__)+s_issock cmode = c_s_issock cmode /= 0+foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt+#else+s_issock _ = False+#endif
System/Posix/Types.hs view
@@ -1,2 +1,202 @@-module System.Posix.Types (module X___) where-import "base" System.Posix.Types as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------+#ifdef __NHC__+#define HTYPE_DEV_T+#define HTYPE_INO_T+#define HTYPE_MODE_T+#define HTYPE_OFF_T+#define HTYPE_PID_T+#define HTYPE_SSIZE_T+#define HTYPE_GID_T+#define HTYPE_NLINK_T+#define HTYPE_UID_T+#define HTYPE_CC_T+#define HTYPE_SPEED_T+#define HTYPE_TCFLAG_T+#define HTYPE_RLIM_T+#define HTYPE_NLINK_T+#define HTYPE_UID_T+#define HTYPE_GID_T+#else+#include "HsBaseConfig.h"+#endif++module System.Posix.Types (++  -- * POSIX data types+#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++  Fd(..),++#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++#ifdef __NHC__+import NHC.PosixTypes+import Foreign.C+#else++import Foreign+import Foreign.C+import Data.Typeable+import Data.Bits++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Enum+import GHC.Num+import GHC.Real+import GHC.Prim+import GHC.Read+import GHC.Show+#else+import Control.Monad+#endif++#include "CTypes.h"++#if defined(HTYPE_DEV_T)+ARITHMETIC_TYPE(CDev,tyConCDev,"CDev",HTYPE_DEV_T)+#endif+#if defined(HTYPE_INO_T)+INTEGRAL_TYPE(CIno,tyConCIno,"CIno",HTYPE_INO_T)+#endif+#if defined(HTYPE_MODE_T)+INTEGRAL_TYPE(CMode,tyConCMode,"CMode",HTYPE_MODE_T)+#endif+#if defined(HTYPE_OFF_T)+INTEGRAL_TYPE(COff,tyConCOff,"COff",HTYPE_OFF_T)+#endif+#if defined(HTYPE_PID_T)+INTEGRAL_TYPE(CPid,tyConCPid,"CPid",HTYPE_PID_T)+#endif++#if defined(HTYPE_SSIZE_T)+INTEGRAL_TYPE(CSsize,tyConCSsize,"CSsize",HTYPE_SSIZE_T)+#endif++#if defined(HTYPE_GID_T)+INTEGRAL_TYPE(CGid,tyConCGid,"CGid",HTYPE_GID_T)+#endif+#if defined(HTYPE_NLINK_T)+INTEGRAL_TYPE(CNlink,tyConCNlink,"CNlink",HTYPE_NLINK_T)+#endif++#if defined(HTYPE_UID_T)+INTEGRAL_TYPE(CUid,tyConCUid,"CUid",HTYPE_UID_T)+#endif+#if defined(HTYPE_CC_T)+ARITHMETIC_TYPE(CCc,tyConCCc,"CCc",HTYPE_CC_T)+#endif+#if defined(HTYPE_SPEED_T)+ARITHMETIC_TYPE(CSpeed,tyConCSpeed,"CSpeed",HTYPE_SPEED_T)+#endif+#if defined(HTYPE_TCFLAG_T)+INTEGRAL_TYPE(CTcflag,tyConCTcflag,"CTcflag",HTYPE_TCFLAG_T)+#endif+#if defined(HTYPE_RLIM_T)+INTEGRAL_TYPE(CRLim,tyConCRlim,"CRLim",HTYPE_RLIM_T)+#endif++-- ToDo: blksize_t, clockid_t, blkcnt_t, fsblkcnt_t, fsfilcnt_t, id_t, key_t+-- suseconds_t, timer_t, useconds_t++-- Make an Fd type rather than using CInt everywhere+INTEGRAL_TYPE(Fd,tyConFd,"Fd",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++#endif /* !__NHC__ */++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 view
@@ -1,2 +1,88 @@-module System.Timeout (module X___) where-import "base" System.Timeout as X___+-------------------------------------------------------------------------------+-- |+-- 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.+--+-------------------------------------------------------------------------------++#ifdef __GLASGOW_HASKELL__+#include "Typeable.h"+#endif++module System.Timeout ( timeout ) where++#ifdef __GLASGOW_HASKELL__+import Prelude             (Show(show), IO, Ord((<)), Eq((==)), Int,+                            otherwise, fmap)+import Data.Maybe          (Maybe(..))+import Control.Monad       (Monad(..))+import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)+import Control.Exception   (Exception, handleJust, throwTo, bracket)+import Data.Typeable+import Data.Unique         (Unique, newUnique)++-- An internal type that is thrown as a dynamic exception to+-- interrupt the running IO computation when the timeout has+-- expired.++data Timeout = Timeout Unique deriving Eq+INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")++instance Show Timeout where+    show _ = "<<timeout>>"++instance Exception Timeout+#endif /* !__GLASGOW_HASKELL__ */++-- |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@.+--+-- 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.+-- 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.++timeout :: Int -> IO a -> IO (Maybe a)+#ifdef __GLASGOW_HASKELL__+timeout n f+    | n <  0    = fmap Just f+    | n == 0    = return Nothing+    | otherwise = do+        pid <- myThreadId+        ex  <- fmap Timeout newUnique+        handleJust (\e -> if e == ex then Just () else Nothing)+                   (\_ -> return Nothing)+                   (bracket (forkIO (threadDelay n >> throwTo pid ex))+                            (killThread)+                            (\_ -> fmap Just f))+#else+timeout n f = fmap Just f+#endif /* !__GLASGOW_HASKELL__ */
Text/ParserCombinators/ReadP.hs view
@@ -1,2 +1,524 @@-module Text.ParserCombinators.ReadP (module X___) where-import "base" Text.ParserCombinators.ReadP as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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+#ifndef __NHC__+  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus+#else+  ReadPN,     -- :: * -> * -> *; instance Functor, Monad, MonadPlus+#endif+  +  -- * Primitive operations+  get,        -- :: ReadP Char+  look,       -- :: ReadP String+  (+++),      -- :: ReadP a -> ReadP a -> ReadP a+  (<++),      -- :: ReadP a -> ReadP a -> ReadP a+  gather,     -- :: ReadP a -> ReadP (String, a)+  +  -- * Other operations+  pfail,      -- :: ReadP a+  satisfy,    -- :: (Char -> Bool) -> ReadP Char+  char,       -- :: Char -> ReadP Char+  string,     -- :: String -> ReadP String+  munch,      -- :: (Char -> Bool) -> ReadP String+  munch1,     -- :: (Char -> Bool) -> ReadP String+  skipSpaces, -- :: ReadP ()+  choice,     -- :: [ReadP a] -> ReadP a+  count,      -- :: Int -> ReadP a -> ReadP [a]+  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a+  option,     -- :: a -> ReadP a -> ReadP a+  optional,   -- :: ReadP a -> ReadP ()+  many,       -- :: ReadP a -> ReadP [a]+  many1,      -- :: ReadP a -> ReadP [a]+  skipMany,   -- :: ReadP a -> ReadP ()+  skipMany1,  -- :: ReadP a -> ReadP ()+  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]+  +  -- * Running a parser+  ReadS,      -- :: *; = String -> [(a,String)]+  readP_to_S, -- :: ReadP a -> ReadS a+  readS_to_P, -- :: ReadS a -> ReadP a+  +  -- * Properties+  -- $properties+  )+ where++import Control.Monad( MonadPlus(..), sequence, liftM2 )++#ifdef __GLASGOW_HASKELL__+#ifndef __HADDOCK__+import {-# SOURCE #-} GHC.Unicode ( isSpace  )+#endif+import GHC.List ( replicate )+import GHC.Base+#else+import Data.Char( isSpace )+#endif++infixr 5 +++, <++++#ifdef __GLASGOW_HASKELL__+------------------------------------------------------------------------+-- 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)]+#endif++-- ---------------------------------------------------------------------------+-- 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 [(a,String)] -- invariant: list is non-empty!++-- Monad, MonadPlus++instance Monad P where+  return x = Result x Fail++  (Get f)      >>= k = Get (\c -> f c >>= k)+  (Look f)     >>= k = Look (\s -> f s >>= k)+  Fail         >>= _ = Fail+  (Result x p) >>= k = k x `mplus` (p >>= k)+  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]++  fail _ = Fail++instance MonadPlus P where+  mzero = Fail++  -- most common case: two gets are combined+  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)+  +  -- results are delivered as soon as possible+  Result x p `mplus` q          = Result x (p `mplus` q)+  p          `mplus` Result x q = Result x (p `mplus` q)++  -- fail disappears+  Fail       `mplus` p          = p+  p          `mplus` 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    `mplus` Final t    = Final (r ++ t)+  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))+  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))+  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))+  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))++  -- two looks are combined (=optimization)+  -- look + sthg else floats upwards+  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)+  Look f     `mplus` p          = Look (\s -> f s `mplus` p)+  p          `mplus` Look f     = Look (\s -> p `mplus` f s)++-- ---------------------------------------------------------------------------+-- The ReadP type++#ifndef __NHC__+newtype ReadP a = R (forall b . (a -> P b) -> P b)+#else+#define ReadP  (ReadPN b)+newtype ReadPN b a = R ((a -> P b) -> P b)+#endif++-- Functor, Monad, MonadPlus++instance Functor ReadP where+  fmap h (R f) = R (\k -> f (k . h))++instance Monad ReadP where+  return x  = R (\k -> k x)+  fail _    = R (\_ -> Fail)+  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))++instance MonadPlus ReadP where+  mzero = pfail+  mplus = (+++)++-- ---------------------------------------------------------------------------+-- Operations over P++final :: [(a,String)] -> P a+-- Maintains invariant for Final constructor+final [] = Fail+final r  = Final r++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)    _     = r+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 `mplus` f2 k)++#ifndef __NHC__+(<++) :: ReadP a -> ReadP a -> ReadP a+#else+(<++) :: ReadPN a a -> ReadPN a a -> ReadPN a a+#endif+-- ^ Local, exclusive, left-biased choice: If left parser+--   locally produces any result at all, then right parser is+--   not used.+#ifdef __GLASGOW_HASKELL__+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#)+#else+R f <++ q =+  do s <- look+     probe (f 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)+#endif++#ifndef __NHC__+gather :: ReadP a -> ReadP (String, a)+#else+-- gather :: ReadPN (String->P b) a -> ReadPN (String->P b) (String, a)+#endif+-- ^ 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 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 []) `mplus` gath l p+  gath _ (Final _)    = error "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 ==)++string :: String -> ReadP String+-- ^ Parses and returns the specified string.+string this = do s <- look; scan this s+ where+  scan []     _               = do return this+  scan (x:xs) (y:ys) | x == y = do get; scan xs ys+  scan _      _               = do pfail++munch :: (Char -> Bool) -> ReadP String+-- ^ Parses the first zero or more characters satisfying the predicate.+munch p =+  do s <- look+     scan s+ where+  scan (c:cs) | p c = do get; s <- scan cs; return (c:s)+  scan _            = do return ""++munch1 :: (Char -> Bool) -> ReadP String+-- ^ Parses the first one or more characters satisfying the predicate.+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 _                 = do 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++#ifndef __NHC__+manyTill :: ReadP a -> ReadP end -> ReadP [a]+#else+manyTill :: ReadPN [a] a -> ReadPN [a] end -> ReadPN [a] [a]+#endif+-- ^ @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++#ifndef __NHC__+readP_to_S :: ReadP a -> ReadS a+#else+readP_to_S :: ReadPN a a -> ReadS a+#endif+-- ^ 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.++We use bags to give semantics to the combinators.++>  type Bag a = [a]++Equality on bags does not care about the order of elements.++>  (=~) :: Ord a => Bag a -> Bag a -> Bool+>  xs =~ ys = sort xs == sort ys++A special equality operator to avoid unresolved overloading+when testing the properties.++>  (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool+>  (=~.) = (=~)++Here follow the properties:++>  prop_Get_Nil =+>    readP_to_S get [] =~ []+>+>  prop_Get_Cons c s =+>    readP_to_S get (c:s) =~ [(c,s)]+>+>  prop_Look s =+>    readP_to_S look s =~ [(s,s)]+>+>  prop_Fail s =+>    readP_to_S pfail s =~. []+>+>  prop_Return x s =+>    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_String_Yes this s =+>    readP_to_S (string this) (this ++ s) =~+>      [(this,s)]+>+>  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 view
@@ -1,2 +1,162 @@-module Text.ParserCombinators.ReadPrec (module X___) where-import "base" Text.ParserCombinators.ReadPrec as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,      -- :: * -> *; instance Functor, Monad, MonadPlus+  +  -- * Precedences+  Prec,          -- :: *; = Int+  minPrec,       -- :: Prec; = 0++  -- * Precedence operations+  lift,          -- :: ReadP a -> ReadPrec a+  prec,          -- :: Prec -> ReadPrec a -> ReadPrec a+  step,          -- :: ReadPrec a -> ReadPrec a+  reset,         -- :: ReadPrec a -> ReadPrec a++  -- * Other operations+  -- | All are based directly on their similarly-named 'ReadP' counterparts.+  get,           -- :: ReadPrec Char+  look,          -- :: ReadPrec String+  (+++),         -- :: ReadPrec a -> ReadPrec a -> ReadPrec a+  (<++),         -- :: ReadPrec a -> ReadPrec a -> ReadPrec a+  pfail,         -- :: ReadPrec a+  choice,        -- :: [ReadPrec a] -> ReadPrec a++  -- * Converters+  readPrec_to_P, -- :: ReadPrec a       -> (Int -> ReadP a)+  readP_to_Prec, -- :: (Int -> ReadP a) -> ReadPrec a+  readPrec_to_S, -- :: ReadPrec a       -> (Int -> ReadS a)+  readS_to_Prec, -- :: (Int -> ReadS a) -> ReadPrec a+  )+ where+++import Text.ParserCombinators.ReadP+  ( ReadP+  , ReadS+  , readP_to_S+  , readS_to_P+  )++import qualified Text.ParserCombinators.ReadP as ReadP+  ( get+  , look+  , (+++), (<++)+  , pfail+  )++import Control.Monad( MonadPlus(..) )+#ifdef __GLASGOW_HASKELL__+import GHC.Num( Num(..) )+import GHC.Base+#endif++-- ---------------------------------------------------------------------------+-- The readPrec type++newtype ReadPrec a = P (Prec -> ReadP a)++-- Functor, Monad, MonadPlus++instance Functor ReadPrec where+  fmap h (P f) = P (\n -> fmap h (f n))++instance Monad ReadPrec where+  return x  = P (\_ -> return x)+  fail s    = P (\_ -> fail s)+  P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)+  +instance MonadPlus ReadPrec where+  mzero = pfail+  mplus = (+++)++-- 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 view
@@ -1,2 +1,322 @@-module Text.Printf (module X___) where-import "base" Text.Printf as X___+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Printf+-- Copyright   :  (c) Lennart Augustsson, 2004-2008+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  lennart@augustsson.net+-- Stability   :  provisional+-- Portability :  portable+--+-- A C printf like formatter.+--+-----------------------------------------------------------------------------++module Text.Printf(+   printf, hPrintf,+   PrintfType, HPrintfType, PrintfArg, IsChar+) where++import Prelude+import Data.Char+import Data.Int+import Data.Word+import Numeric(showEFloat, showFFloat, showGFloat)+import System.IO++-------------------++-- | Format a variable number of arguments with the C-style formatting string.+-- The return value is either 'String' or @('IO' a)@.+--+-- 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 conversion specification begins with the+-- character @%@, followed by one or more of the following flags:+--+-- >    -      left adjust (default is right adjust)+-- >    +      always use a sign (+ or -) for signed conversions+-- >    0      pad with zeroes rather than spaces+--+-- followed optionally by a field width:+-- +-- >    num    field width+-- >    *      as num, but taken from argument list+--+-- followed optionally by a precision:+--+-- >    .num   precision (number of decimal places)+--+-- and finally, a format character:+--+-- >    c      character               Char, Int, Integer, ...+-- >    d      decimal                 Char, Int, Integer, ...+-- >    o      octal                   Char, Int, Integer, ...+-- >    x      hexadecimal             Char, Int, Integer, ...+-- >    X      hexadecimal             Char, Int, Integer, ...+-- >    u      unsigned decimal        Char, Int, Integer, ...+-- >    f      floating point          Float, Double+-- >    g      general format float    Float, Double+-- >    G      general format float    Float, Double+-- >    e      exponent format float   Float, Double+-- >    E      exponent format float   Float, Double+-- >    s      string                  String+--+-- Mismatch between the argument types and the format string will cause+-- an exception to be thrown at runtime.+--+-- Examples:+--+-- >   > printf "%d\n" (23::Int)+-- >   23+-- >   > printf "%s %s\n" "Hello" "World"+-- >   Hello World+-- >   > printf "%.2f\n" pi+-- >   3.14+--+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 98+instance PrintfType String where+    spr fmt args = uprintf fmt (reverse args)+-}+instance (IsChar c) => PrintfType [c] where+    spr fmts args = map fromChar (uprintf fmts (reverse args))++instance PrintfType (IO a) where+    spr fmts args = do+	putStr (uprintf fmts (reverse args))+	return undefined++instance HPrintfType (IO a) where+    hspr hdl fmts args = do+	hPutStr hdl (uprintf fmts (reverse args))+	return undefined++instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where+    spr fmts args = \ a -> spr fmts (toUPrintf a : args)++instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where+    hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)++class PrintfArg a where+    toUPrintf :: a -> UPrintf++instance PrintfArg Char where+    toUPrintf c = UChar c++{- not allowed in Haskell 98+instance PrintfArg String where+    toUPrintf s = UString s+-}+instance (IsChar c) => PrintfArg [c] where+    toUPrintf = UString . map toChar++instance PrintfArg Int where+    toUPrintf = uInteger++instance PrintfArg Int8 where+    toUPrintf = uInteger++instance PrintfArg Int16 where+    toUPrintf = uInteger++instance PrintfArg Int32 where+    toUPrintf = uInteger++instance PrintfArg Int64 where+    toUPrintf = uInteger++#ifndef __NHC__+instance PrintfArg Word where+    toUPrintf = uInteger+#endif++instance PrintfArg Word8 where+    toUPrintf = uInteger++instance PrintfArg Word16 where+    toUPrintf = uInteger++instance PrintfArg Word32 where+    toUPrintf = uInteger++instance PrintfArg Word64 where+    toUPrintf = uInteger++instance PrintfArg Integer where+    toUPrintf = UInteger 0++instance PrintfArg Float where+    toUPrintf = UFloat++instance PrintfArg Double where+    toUPrintf = UDouble++uInteger :: (Integral a, Bounded a) => a -> UPrintf+uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)++class IsChar c where+    toChar :: c -> Char+    fromChar :: Char -> c++instance IsChar Char where+    toChar c = c+    fromChar c = c++-------------------++data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double++uprintf :: String -> [UPrintf] -> String+uprintf ""       []       = ""+uprintf ""       (_:_)    = fmterr+uprintf ('%':'%':cs) us   = '%':uprintf cs us+uprintf ('%':_)  []       = argerr+uprintf ('%':cs) us@(_:_) = fmt cs us+uprintf (c:cs)   us       = c:uprintf cs us++fmt :: String -> [UPrintf] -> String+fmt cs us =+	let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us+	    adjust (pre, str) = +		let lstr = length str+		    lpre = length pre+		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""+		in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str+            adjust' ("", str) | plus = adjust ("+", str)+            adjust' ps = adjust ps+        in+	case cs' of+	[]     -> fmterr+	c:cs'' ->+	    case us' of+	    []     -> argerr+	    u:us'' ->+		(case c of+		'c' -> adjust  ("", [toEnum (toint u)])+		'd' -> adjust' (fmti u)+		'i' -> adjust' (fmti u)+		'x' -> adjust  ("", fmtu 16 u)+		'X' -> adjust  ("", map toUpper $ fmtu 16 u)+		'o' -> adjust  ("", fmtu 8  u)+		'u' -> adjust  ("", fmtu 10 u)+		'e' -> adjust' (dfmt' c prec u)+		'E' -> adjust' (dfmt' c prec u)+		'f' -> adjust' (dfmt' c prec u)+		'g' -> adjust' (dfmt' c prec u)+		'G' -> adjust' (dfmt' c prec u)+		's' -> adjust  ("", tostr prec u)+		_   -> perror ("bad formatting char " ++ [c])+		 ) ++ uprintf cs'' us''++fmti :: UPrintf -> (String, String)+fmti (UInteger _ i) = if i < 0 then ("-", show (-i)) else ("", show i)+fmti (UChar c)      = fmti (uInteger (fromEnum c))+fmti _		    = baderr++fmtu :: Integer -> UPrintf -> String+fmtu b (UInteger l i) = itosb b (if i < 0 then -2*l + i else i)+fmtu b (UChar c)      = itosb b (toInteger (fromEnum c))+fmtu _ _              = baderr++toint :: UPrintf -> Int+toint (UInteger _ i) = fromInteger i+toint (UChar c)      = fromEnum c+toint _		     = baderr++tostr :: Int -> UPrintf -> String+tostr n (UString s) = if n >= 0 then take n s else s+tostr _ _		  = baderr++itosb :: Integer -> Integer -> String+itosb b n = +	if n < b then +	    [intToDigit $ fromInteger n]+	else+	    let (q, r) = quotRem n b in+	    itosb b q ++ [intToDigit $ fromInteger r]++stoi :: Int -> String -> (Int, String)+stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs+stoi a cs                 = (a, cs)++getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])+getSpecs _ z s ('-':cs) us = getSpecs True z s cs us+getSpecs l z _ ('+':cs) us = getSpecs l z True cs us+getSpecs l _ s ('0':cs) us = getSpecs l True s cs us+getSpecs l z s ('*':cs) us =+	let (us', n) = getStar us+	    ((p, cs''), us'') =+		    case cs of+                    '.':'*':r -> let (us''', p') = getStar us'+		    	      	 in  ((p', r), us''')+		    '.':r     -> (stoi 0 r, us')+		    _         -> ((-1, cs), us')+	in  (n, p, l, z, s, cs'', us'')+getSpecs l z s ('.':cs) us =+	let ((p, cs'), us') = +	        case cs of+		'*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')+                _ ->        (stoi 0 cs, us)+	in  (0, p, l, z, s, cs', us')+getSpecs l z s cs@(c:_) us | isDigit c =+	let (n, cs') = stoi 0 cs+	    ((p, cs''), us') = case cs' of+	    	 	       '.':'*':r -> let (us'', p') = getStar us in ((p', r), us'')+		               '.':r -> (stoi 0 r, us)+			       _     -> ((-1, cs'), us)+	in  (n, p, l, z, s, cs'', us')+getSpecs l z s cs       us = (0, -1, l, z, s, cs, us)++getStar :: [UPrintf] -> ([UPrintf], Int)+getStar us =+    case us of+    [] -> argerr+    nu : us' -> (us', toint nu)+++dfmt' :: Char -> Int -> UPrintf -> (String, String)+dfmt' c p (UDouble d) = dfmt c p d+dfmt' c p (UFloat f)  = dfmt c p f+dfmt' _ _ _           = baderr++dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)+dfmt c p d =+	case (if isUpper c then map toUpper else id) $+             (case toLower c of+                  'e' -> showEFloat+                  'f' -> showFFloat+                  'g' -> showGFloat+                  _   -> error "Printf.dfmt: impossible"+             )+               (if p < 0 then Nothing else Just p) d "" of+	'-':cs -> ("-", cs)+	cs     -> ("" , cs)++perror :: String -> a+perror s = error ("Printf.printf: "++s)+fmterr, argerr, baderr :: a+fmterr = perror "formatting string ended prematurely"+argerr = perror "argument list ended prematurely"+baderr = perror "bad argument"
Text/Read.hs view
@@ -1,2 +1,100 @@-module Text.Read (module X___) where-import "base" Text.Read as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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 98 'Read'.  In particular, writing parsers is easier, and+-- the parsers are much more efficient.+--+-----------------------------------------------------------------------------++module Text.Read (+   -- * The 'Read' class+   Read(..),            -- The Read class+   ReadS,               -- String -> Maybe (a,String)++   -- * Haskell 98 functions+   reads,               -- :: (Read a) => ReadS a+   read,                -- :: (Read a) => String -> a+   readParen,           -- :: Bool -> ReadS a -> ReadS a+   lex,                 -- :: ReadS String++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+   -- * New parsing functions+   module Text.ParserCombinators.ReadPrec,+   L.Lexeme(..),+   lexP,                -- :: ReadPrec Lexeme+   parens,              -- :: ReadPrec a -> ReadPrec a+#endif+#ifdef __GLASGOW_HASKELL__+   readListDefault,     -- :: Read a => ReadS [a]+   readListPrecDefault, -- :: Read a => ReadPrec [a]+#endif++ ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Read+import Data.Either+import Text.ParserCombinators.ReadP as P+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+import Text.ParserCombinators.ReadPrec+import qualified Text.Read.Lex as L+#endif++#ifdef __HUGS__+-- copied from GHC.Read++lexP :: ReadPrec L.Lexeme+lexP = lift L.lex++parens :: ReadPrec a -> ReadPrec a+parens p = optional+ where+  optional  = p +++ mandatory+  mandatory = do+    L.Punc "(" <- lexP+    x          <- reset optional+    L.Punc ")" <- lexP+    return x+#endif++#ifdef __GLASGOW_HASKELL__+------------------------------------------------------------------------+-- utility functions++-- | equivalent to 'readsPrec' with a precedence of 0.+reads :: Read a => ReadS a+reads = readsPrec minPrec++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++-- | The 'read' function reads input from a string, which must be+-- completely consumed by the input process.+read :: Read a => String -> a+read s = either error id (readEither s)+#endif+
Text/Read/Lex.hs view
@@ -1,2 +1,445 @@-module Text.Read.Lex (module X___) where-import "base" Text.Read.Lex as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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(..)  -- :: *; Show, Eq++  -- lexer      +  , lex         -- :: ReadP Lexeme      Skips leading spaces+  , hsLex       -- :: ReadP String+  , lexChar     -- :: ReadP Char        Reads just one char, with H98 escapes++  , readIntP    -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a+  , readOctP    -- :: Num a => ReadP a +  , readDecP    -- :: Num a => ReadP a+  , readHexP    -- :: Num a => ReadP a+  )+ where++import Text.ParserCombinators.ReadP++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Num( Num(..), Integer )+import GHC.Show( Show(..) )+#ifndef __HADDOCK__+import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )+#endif+import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral, +                 toInteger, (^), (^^), infinity, notANumber )+import GHC.List+import GHC.Enum( maxBound )+#else+import Prelude hiding ( lex )+import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )+import Data.Ratio( Ratio, (%) )+#endif+#ifdef __HUGS__+import Hugs.Prelude( Ratio(..) )+#endif+import Data.Maybe+import Control.Monad++-- -----------------------------------------------------------------------------+-- 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. @>>@, @:%@+  | Int Integer         -- ^ Integer literal+  | Rat Rational        -- ^ Floating point literal+  | EOF+ deriving (Eq, Show)++-- -----------------------------------------------------------------------------+-- Lexing++lex :: ReadP Lexeme+lex = skipSpaces >> lexToken++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])+ where+  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+  isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"+  reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]++-- ----------------------------------------------------------------------+-- identifiers++lexId :: ReadP Lexeme+lexId = lex_nan <++ lex_id+  where+        -- NaN and Infinity look like identifiers, so+        -- we parse them first.  +    lex_nan = (string "NaN"      >> return (Rat notANumber)) ++++              (string "Infinity" >> return (Rat infinity))+  +    lex_id = do c <- satisfy isIdsChar+                s <- munch isIdfChar+                return (Ident (c:s))++          -- Identifiers can start with a '_'+    isIdsChar c = isAlpha c || c == '_'+    isIdfChar c = isAlphaNum c || c `elem` "_'"++#ifndef __GLASGOW_HASKELL__+infinity, notANumber :: Rational+infinity   = 1 :% 0+notANumber = 0 :% 0+#endif++-- ---------------------------------------------------------------------------+-- 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; return c }++lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?+lexCharE =+  do c1 <- get+     if c1 == '\\'+       then do c2 <- lexEsc; return (c2, True)+       else do 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 =+    do 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+         '&'           -> do return ()+         _ | isSpace c -> do skipSpaces; char '\\'; return ()+         _             -> do 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 (Int (val (fromIntegral base) 0 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 (value xs mFrac mExp)+ where+  value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp+  +  valueFracExp :: Integer -> Maybe Digits -> Maybe Integer +               -> Lexeme+  valueFracExp a Nothing Nothing        +    = Int a                                             -- 43+  valueFracExp a Nothing (Just exp)+    | exp >= 0  = Int (a * (10 ^ exp))                  -- 43e7+    | otherwise = Rat (valExp (fromInteger a) exp)      -- 43e-7+  valueFracExp a (Just fs) mExp +     = case mExp of+         Nothing  -> Rat rat                            -- 4.3+         Just exp -> Rat (valExp rat exp)               -- 4.3e-4+     where+        rat :: Rational+        rat = fromInteger a + frac 10 0 1 fs++  valExp :: Rational -> Integer -> Rational+  valExp rat exp = rat * (10 ^^ exp)++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 -> do return (f [])+  scan []     f = do return (f [])++lexInteger :: Base -> ReadP Integer+lexInteger base =+  do xs <- lexDigits base+     return (val (fromIntegral base) 0 xs)++val :: Num a => a -> a -> Digits -> a+-- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were+val _    y []     = y+val base y (x:xs) = y' `seq` val base y' xs+ where+  y' = y * base + fromIntegral x++frac :: Integral a => a -> a -> a -> Digits -> Ratio a+frac _    a b []     = a % b+frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs+ where+  a' = a * base + fromIntegral x+  b' = b * base++valDig :: Num a => a -> Char -> Maybe Int+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 _ _ = error "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 0 (map valDigit s))++readIntP' :: 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)++readOctP, readDecP, readHexP :: Num a => ReadP a+readOctP = readIntP' 8+readDecP = readIntP' 10+readHexP = readIntP' 16
Text/Show.hs view
@@ -1,2 +1,47 @@-module Text.Show (module X___) where-import "base" Text.Show as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- 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,               -- String -> String+   Show(+      showsPrec,        -- :: Int -> a -> ShowS+      show,             -- :: a   -> String+      showList          -- :: [a] -> ShowS +    ),+   shows,               -- :: (Show a) => a -> ShowS+   showChar,            -- :: Char -> ShowS+   showString,          -- :: String -> ShowS+   showParen,           -- :: Bool -> ShowS -> ShowS+   showListWith,        -- :: (a -> ShowS) -> [a] -> ShowS + ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Show+#endif++-- | Show a list (using square brackets and commas), given a function+-- for showing elements.+showListWith :: (a -> ShowS) -> [a] -> ShowS+showListWith = showList__++#ifndef __GLASGOW_HASKELL__+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)+#endif
Text/Show/Functions.hs view
@@ -1,2 +1,34 @@-module Text.Show.Functions ({- empty: module X___ -}) where-import "base" Text.Show.Functions as X___ ()+{-# OPTIONS_GHC -fno-warn-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++#ifndef __NHC__+instance Show (a -> b) where+	showsPrec _ _ = showString "<function>"+#else+instance (Show a,Show b) => Show (a->b) where+  showsPrec d a = showString "<<function>>"++  showsType a = showChar '(' . showsType value  . showString " -> " .+                               showsType result . showChar ')'+                where (value,result) = getTypes undefined+                      getTypes x = (x,a x)+#endif
Unsafe/Coerce.hs view
@@ -1,2 +1,42 @@-module Unsafe.Coerce (module X___) where-import "base" Unsafe.Coerce as X___+{-# OPTIONS_GHC -XNoImplicitPrelude #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Unsafe.Coerce+-- Copyright   :  Malcolm Wallace 2006+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The highly unsafe primitive 'unsafeCoerce' converts a value from any+-- type to any other type.  Needless to say, if you use this function,+-- it is your responsibility to ensure that the old and new types have+-- identical internal representations, in order to prevent runtime corruption.+--+-- The types for which 'unsafeCoerce' is representation-safe may differ+-- from compiler to compiler (and version to version).+--+--   * Documentation for correct usage in GHC will be found under+--     'unsafeCoerce#' in GHC.Base (around which 'unsafeCoerce' is just a+--     trivial wrapper).+--+--   * In nhc98, the only representation-safe coercions are between Enum+--     types with the same range (e.g. Int, Int32, Char, Word32),+--     or between a newtype and the type that it wraps.++module Unsafe.Coerce (unsafeCoerce) where++#if defined(__GLASGOW_HASKELL__)+import GHC.Prim (unsafeCoerce#)+unsafeCoerce :: a -> b+unsafeCoerce = unsafeCoerce#+#endif++#if defined(__NHC__)+import NonStdUnsafeCoerce (unsafeCoerce)+#endif++#if defined(__HUGS__)+import Hugs.IOExts (unsafeCoerce)+#endif
+ aclocal.m4 view
@@ -0,0 +1,226 @@+# FP_COMPUTE_INT(EXPRESSION, VARIABLE, 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.+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([$1], fp_check_const_result, [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],+[AC_FOREACH([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 ** Map an arithmetic C type to a Haskell type.+dnl    Based on autconf's AC_CHECK_SIZEOF.++dnl FPTOOLS_CHECK_HTYPE(TYPE [, DEFAULT_VALUE, [, VALUE-FOR-CROSS-COMPILATION])+AC_DEFUN([FPTOOLS_CHECK_HTYPE],+[changequote(<<, >>)dnl+dnl The name to #define.+define(<<AC_TYPE_NAME>>, translit(htype_$1, [a-z *], [A-Z_P]))dnl+dnl The cache variable name.+define(<<AC_CV_NAME>>, translit(fptools_cv_htype_$1, [ *], [_p]))dnl+define(<<AC_CV_NAME_supported>>, translit(fptools_cv_htype_sup_$1, [ *], [_p]))dnl+changequote([, ])dnl+AC_MSG_CHECKING(Haskell type for $1)+AC_CACHE_VAL(AC_CV_NAME,+[AC_CV_NAME_supported=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+AC_RUN_IFELSE([AC_LANG_SOURCE([[#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef $1 testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}]])],[AC_CV_NAME=`cat conftestval`],+[ifelse([$2], , [AC_CV_NAME=NotReallyAType; AC_CV_NAME_supported=no], [AC_CV_NAME=$2])],+[ifelse([$3], , [AC_CV_NAME=NotReallyATypeCross; AC_CV_NAME_supported=no], [AC_CV_NAME=$3])])+CPPFLAGS="$fp_check_htype_save_cppflags"]) dnl+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])+else+  AC_MSG_RESULT([not supported])+fi+undefine([AC_TYPE_NAME])dnl+undefine([AC_CV_NAME])dnl+undefine([AC_CV_NAME_supported])dnl+])+++# FP_READDIR_EOF_ERRNO+# --------------------+# Defines READDIR_ERRNO_EOF to what readdir() sets 'errno' to upon reaching end+# of directory (not set => 0); not setting it is the correct thing to do, but+# MinGW based versions have set it to ENOENT until recently (summer 2004).+AC_DEFUN([FP_READDIR_EOF_ERRNO],+[AC_CACHE_CHECK([what readdir sets errno to upon EOF], [fptools_cv_readdir_eof_errno],+[AC_RUN_IFELSE([AC_LANG_SOURCE([[#include <dirent.h>+#include <stdio.h>+#include <errno.h>+int+main(argc, argv)+int argc;+char **argv;+{+  FILE *f=fopen("conftestval", "w");+#if defined(__MINGW32__)+  int fd = mkdir("testdir");+#else+  int fd = mkdir("testdir", 0666);+#endif+  DIR* dp;+  struct dirent* de;+  int err = 0;++  if (!f) return 1;+  if (fd == -1) { +     fprintf(stderr,"unable to create directory; quitting.\n");+     return 1;+  }+  close(fd);+  dp = opendir("testdir");+  if (!dp) { +     fprintf(stderr,"unable to browse directory; quitting.\n");+     rmdir("testdir");+     return 1;+  }++  /* the assumption here is that readdir() will only return NULL+   * due to reaching the end of the directory.+   */+  while (de = readdir(dp)) {+  	;+  }+  err = errno;+  fprintf(f,"%d", err);+  fclose(f);+  closedir(dp);+  rmdir("testdir");+  return 0;+}]])],+[fptools_cv_readdir_eof_errno=`cat conftestval`],+[AC_MSG_WARN([failed to determine the errno value])+ fptools_cv_readdir_eof_errno=0],+[fptools_cv_readdir_eof_errno=0])])+AC_DEFINE_UNQUOTED([READDIR_ERRNO_EOF], [$fptools_cv_readdir_eof_errno], [readdir() sets errno to this upon EOF])+])# FP_READDIR_EOF_ERRNO
base.cabal view
@@ -1,48 +1,34 @@ name:           base-version:        3.0.3.2+version:        4.0.0.0 license:        BSD3 license-file:   LICENSE maintainer:     libraries@haskell.org-bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/base-synopsis:       Basic libraries (backwards-compatibility version)+synopsis:       Basic libraries description:-    This is a backwards-compatible version of the base package.-    It depends on a later version of base, and was probably supplied-    with your compiler when it was installed.-    -cabal-version:  >=1.6-build-type: Simple--source-repository head-    type:     darcs-    location: http://darcs.haskell.org/packages/base3-compat+    This package contains the Prelude and its support libraries,+    and a large collection of useful libraries ranging from data+    structures to parsing combinators and debugging utilities.+cabal-version: >= 1.2.3+build-type: Configure+extra-tmp-files:+                config.log config.status autom4te.cache+                include/HsBaseConfig.h+extra-source-files:+                config.guess config.sub install-sh+                aclocal.m4 configure.ac configure+                include/CTypes.h  Library {-    build-depends: base       >= 4.0 && < 4.3,-                   syb        >= 0.1 && < 0.2-    extensions: PackageImports,CPP-    ghc-options: -fno-warn-deprecations--    if impl(ghc < 6.9) {-        buildable: False-    }-     if impl(ghc) {+        build-depends: rts, ghc-prim, integer         exposed-modules:-            Data.Generics,-            Data.Generics.Aliases,-            Data.Generics.Basics,-            Data.Generics.Instances,-            Data.Generics.Schemes,-            Data.Generics.Text,-            Data.Generics.Twins,             Foreign.Concurrent,             GHC.Arr,             GHC.Base,+            GHC.Classes,             GHC.Conc,             GHC.ConsoleHandler,             GHC.Desugar,-            GHC.Dotnet,             GHC.Enum,             GHC.Environment,             GHC.Err,@@ -71,6 +57,12 @@             GHC.Weak,             GHC.Word,             System.Timeout+        extensions: MagicHash, ExistentialQuantification, Rank2Types,+                    ScopedTypeVariables, UnboxedTuples,+                    ForeignFunctionInterface, UnliftedFFITypes,+                    DeriveDataTypeable, GeneralizedNewtypeDeriving,+                    FlexibleInstances, PatternSignatures, StandaloneDeriving,+                    PatternGuards, EmptyDataDecls     }     exposed-modules:         Control.Applicative,@@ -83,12 +75,14 @@         Control.Concurrent.QSemN,         Control.Concurrent.SampleVar,         Control.Exception,+        Control.Exception.Base+        Control.OldException,         Control.Monad,         Control.Monad.Fix,         Control.Monad.Instances,-        Control.Monad.ST,-        Control.Monad.ST.Lazy,-        Control.Monad.ST.Strict,+        Control.Monad.ST+        Control.Monad.ST.Lazy+        Control.Monad.ST.Strict         Data.Bits,         Data.Bool,         Data.Char,@@ -96,6 +90,7 @@         Data.Dynamic,         Data.Either,         Data.Eq,+        Data.Data,         Data.Fixed,         Data.Foldable         Data.Function,@@ -108,9 +103,9 @@         Data.Monoid,         Data.Ord,         Data.Ratio,-        Data.STRef,-        Data.STRef.Lazy,-        Data.STRef.Strict,+        Data.STRef+        Data.STRef.Lazy+        Data.STRef.Strict         Data.String,         Data.Traversable         Data.Tuple,@@ -136,7 +131,7 @@         Foreign.Storable,         Numeric,         Prelude,-        System.Console.GetOpt,+        System.Console.GetOpt         System.CPUTime,         System.Environment,         System.Exit,@@ -157,4 +152,23 @@         Text.Show,         Text.Show.Functions         Unsafe.Coerce+    c-sources:+        cbits/PrelIOUtils.c+        cbits/WCsubst.c+        cbits/Win32Utils.c+        cbits/consUtils.c+        cbits/dirUtils.c+        cbits/inputReady.c+        cbits/selectUtils.c+    include-dirs: include+    includes:    HsBase.h+    install-includes:    HsBase.h HsBaseConfig.h WCsubst.h dirUtils.h consUtils.h Typeable.h+    if os(windows) {+        extra-libraries: wsock32, msvcrt, kernel32, user32, shell32+    }+    extensions: CPP+    -- We need to set the package name to base (without a version number)+    -- as it's magic.+    ghc-options: -package-name base+    nhc98-options: -H4M -K3M }
+ cbits/PrelIOUtils.c view
@@ -0,0 +1,27 @@+/* + * (c) The University of Glasgow 2002+ *+ * static versions of the inline functions in HsCore.h+ */++#define INLINE++#ifdef __GLASGOW_HASKELL__+# include "Rts.h"+#endif++#include "HsBase.h"++#ifdef __GLASGOW_HASKELL__+# include "RtsMessages.h"++void errorBelch2(const char*s, char *t)+{+    errorBelch(s,t);+}++void debugBelch2(const char*s, char *t)+{+    debugBelch(s,t);+}+#endif /* __GLASGOW_HASKELL__ */
+ cbits/WCsubst.c view
@@ -0,0 +1,4143 @@+/*-------------------------------------------------------------------------+This is an automatically generated file: do not edit+Generated by ubconfc at Fri Jun 13 20:47:01 BST 2008+-------------------------------------------------------------------------*/++#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_LO 262144+#define GENCAT_PC 2048+#define GENCAT_PD 128+#define GENCAT_MN 2097152+#define GENCAT_PE 32+#define GENCAT_NL 16777216+#define GENCAT_PF 131072+#define GENCAT_LT 524288+#define GENCAT_LU 512+#define GENCAT_NO 65536+#define GENCAT_PI 16384+#define GENCAT_SC 8+#define GENCAT_PO 4+#define GENCAT_PS 16+#define GENCAT_SK 1024+#define GENCAT_SM 64+#define GENCAT_SO 8192+#define GENCAT_CC 1+#define GENCAT_CF 32768+#define GENCAT_CO 268435456+#define GENCAT_ZL 33554432+#define GENCAT_CS 134217728+#define GENCAT_ZP 67108864+#define GENCAT_ZS 2+#define GENCAT_MC 8388608+#define GENCAT_ME 4194304+#define GENCAT_ND 256+#define GENCAT_LL 4096+#define GENCAT_LM 1048576+#define MAX_UNI_CHAR 1114109+#define NUM_BLOCKS 2562+#define NUM_CONVBLOCKS 1202+#define NUM_SPACEBLOCKS 8+#define NUM_LAT1BLOCKS 63+#define NUM_RULES 161+static const struct _convrule_ rule155={GENCAT_LL, NUMCAT_LL, 1, -7264, 0, -7264};+static const struct _convrule_ rule36={GENCAT_LU, NUMCAT_LU, 1, 0, 211, 0};+static const struct _convrule_ rule25={GENCAT_LU, NUMCAT_LU, 1, 0, -121, 0};+static const struct _convrule_ rule18={GENCAT_LL, NUMCAT_LL, 1, 743, 0, 743};+static const struct _convrule_ rule105={GENCAT_LU, NUMCAT_LU, 1, 0, 80, 0};+static const struct _convrule_ rule50={GENCAT_LL, NUMCAT_LL, 1, -79, 0, -79};+static const struct _convrule_ rule103={GENCAT_LL, NUMCAT_LL, 1, -96, 0, -96};+static const struct _convrule_ rule76={GENCAT_LL, NUMCAT_LL, 1, -69, 0, -69};+static const struct _convrule_ rule123={GENCAT_LL, NUMCAT_LL, 1, 128, 0, 128};+static const struct _convrule_ rule116={GENCAT_LL, NUMCAT_LL, 1, -59, 0, -59};+static const struct _convrule_ rule99={GENCAT_LL, NUMCAT_LL, 1, -86, 0, -86};+static const struct _convrule_ rule38={GENCAT_LL, NUMCAT_LL, 1, 163, 0, 163};+static const struct _convrule_ rule110={GENCAT_LL, NUMCAT_LL, 1, -48, 0, -48};+static const struct _convrule_ rule130={GENCAT_LL, NUMCAT_LL, 1, -7205, 0, -7205};+static const struct _convrule_ rule125={GENCAT_LL, NUMCAT_LL, 1, 126, 0, 126};+static const struct _convrule_ rule94={GENCAT_LL, NUMCAT_LL, 1, -57, 0, -57};+static const struct _convrule_ rule156={GENCAT_LU, NUMCAT_LU, 1, 0, -35332, 0};+static const struct _convrule_ rule133={GENCAT_LU, NUMCAT_LU, 1, 0, -112, 0};+static const struct _convrule_ rule96={GENCAT_LL, NUMCAT_LL, 1, -47, 0, -47};+static const struct _convrule_ rule87={GENCAT_LL, NUMCAT_LL, 1, -38, 0, -38};+static const struct _convrule_ rule32={GENCAT_LU, NUMCAT_LU, 1, 0, 202, 0};+static const struct _convrule_ rule142={GENCAT_LL, NUMCAT_LL, 1, -28, 0, -28};+static const struct _convrule_ rule90={GENCAT_LL, NUMCAT_LL, 1, -64, 0, -64};+static const struct _convrule_ rule88={GENCAT_LL, NUMCAT_LL, 1, -37, 0, -37};+static const struct _convrule_ rule59={GENCAT_LU, NUMCAT_LU, 1, 0, 71, 0};+static const struct _convrule_ rule97={GENCAT_LL, NUMCAT_LL, 1, -54, 0, -54};+static const struct _convrule_ rule91={GENCAT_LL, NUMCAT_LL, 1, -63, 0, -63};+static const struct _convrule_ rule35={GENCAT_LL, NUMCAT_LL, 1, 97, 0, 97};+static const struct _convrule_ rule146={GENCAT_SO, NUMCAT_SO, 1, -26, 0, -26};+static const struct _convrule_ rule100={GENCAT_LL, NUMCAT_LL, 1, -80, 0, -80};+static const struct _convrule_ rule93={GENCAT_LL, NUMCAT_LL, 1, -62, 0, -62};+static const struct _convrule_ rule78={GENCAT_LL, NUMCAT_LL, 1, -71, 0, -71};+static const struct _convrule_ rule9={GENCAT_LU, NUMCAT_LU, 1, 0, 32, 0};+static const struct _convrule_ rule144={GENCAT_NL, NUMCAT_NL, 1, -16, 0, -16};+static const struct _convrule_ rule140={GENCAT_LU, NUMCAT_LU, 1, 0, -8262, 0};+static const struct _convrule_ rule124={GENCAT_LL, NUMCAT_LL, 1, 112, 0, 112};+static const struct _convrule_ rule121={GENCAT_LL, NUMCAT_LL, 1, 86, 0, 86};+static const struct _convrule_ rule40={GENCAT_LL, NUMCAT_LL, 1, 130, 0, 130};+static const struct _convrule_ rule20={GENCAT_LL, NUMCAT_LL, 1, 121, 0, 121};+static const struct _convrule_ rule108={GENCAT_LL, NUMCAT_LL, 1, -15, 0, -15};+static const struct _convrule_ rule12={GENCAT_LL, NUMCAT_LL, 1, -32, 0, -32};+static const struct _convrule_ rule82={GENCAT_MN, NUMCAT_MN, 1, 84, 0, 84};+static const struct _convrule_ rule160={GENCAT_LL, NUMCAT_LL, 1, -40, 0, -40};+static const struct _convrule_ rule122={GENCAT_LL, NUMCAT_LL, 1, 100, 0, 100};+static const struct _convrule_ rule120={GENCAT_LL, NUMCAT_LL, 1, 74, 0, 74};+static const struct _convrule_ rule89={GENCAT_LL, NUMCAT_LL, 1, -31, 0, -31};+static const struct _convrule_ rule56={GENCAT_LU, NUMCAT_LU, 1, 0, 10792, 0};+static const struct _convrule_ rule46={GENCAT_LL, NUMCAT_LL, 1, 56, 0, 56};+static const struct _convrule_ rule33={GENCAT_LU, NUMCAT_LU, 1, 0, 203, 0};+static const struct _convrule_ rule147={GENCAT_LU, NUMCAT_LU, 1, 0, -10743, 0};+static const struct _convrule_ rule39={GENCAT_LU, NUMCAT_LU, 1, 0, 213, 0};+static const struct _convrule_ rule154={GENCAT_LU, NUMCAT_LU, 1, 0, -10783, 0};+static const struct _convrule_ rule55={GENCAT_LU, NUMCAT_LU, 1, 0, -163, 0};+static const struct _convrule_ rule148={GENCAT_LU, NUMCAT_LU, 1, 0, -3814, 0};+static const struct _convrule_ rule139={GENCAT_LU, NUMCAT_LU, 1, 0, -8383, 0};+static const struct _convrule_ rule98={GENCAT_LL, NUMCAT_LL, 1, -8, 0, -8};+static const struct _convrule_ rule86={GENCAT_LU, NUMCAT_LU, 1, 0, 63, 0};+static const struct _convrule_ rule41={GENCAT_LU, NUMCAT_LU, 1, 0, 214, 0};+static const struct _convrule_ rule115={GENCAT_LL, NUMCAT_LL, 1, 3814, 0, 3814};+static const struct _convrule_ rule26={GENCAT_LL, NUMCAT_LL, 1, -300, 0, -300};+static const struct _convrule_ rule112={GENCAT_LU, NUMCAT_LU, 1, 0, 7264, 0};+static const struct _convrule_ rule22={GENCAT_LL, NUMCAT_LL, 1, -1, 0, -1};+static const struct _convrule_ rule117={GENCAT_LU, NUMCAT_LU, 1, 0, -7615, 0};+static const struct _convrule_ rule49={GENCAT_LL, NUMCAT_LL, 1, -2, 0, -1};+static const struct _convrule_ rule128={GENCAT_LU, NUMCAT_LU, 1, 0, -74, 0};+static const struct _convrule_ rule85={GENCAT_LU, NUMCAT_LU, 1, 0, 64, 0};+static const struct _convrule_ rule30={GENCAT_LU, NUMCAT_LU, 1, 0, 205, 0};+static const struct _convrule_ rule114={GENCAT_LL, NUMCAT_LL, 1, 35332, 0, 35332};+static const struct _convrule_ rule107={GENCAT_LU, NUMCAT_LU, 1, 0, 15, 0};+static const struct _convrule_ rule127={GENCAT_LL, NUMCAT_LL, 1, 9, 0, 9};+static const struct _convrule_ rule118={GENCAT_LL, NUMCAT_LL, 1, 8, 0, 8};+static const struct _convrule_ rule92={GENCAT_LU, NUMCAT_LU, 1, 0, 8, 0};+static const struct _convrule_ rule54={GENCAT_LU, NUMCAT_LU, 1, 0, 10795, 0};+static const struct _convrule_ rule29={GENCAT_LU, NUMCAT_LU, 1, 0, 206, 0};+static const struct _convrule_ rule135={GENCAT_LU, NUMCAT_LU, 1, 0, -126, 0};+static const struct _convrule_ rule101={GENCAT_LL, NUMCAT_LL, 1, 7, 0, 7};+static const struct _convrule_ rule57={GENCAT_LU, NUMCAT_LU, 1, 0, -195, 0};+static const struct _convrule_ rule143={GENCAT_NL, NUMCAT_NL, 1, 0, 16, 0};+static const struct _convrule_ rule145={GENCAT_SO, NUMCAT_SO, 1, 0, 26, 0};+static const struct _convrule_ rule104={GENCAT_LU, NUMCAT_LU, 1, 0, -7, 0};+static const struct _convrule_ rule52={GENCAT_LU, NUMCAT_LU, 1, 0, -56, 0};+static const struct _convrule_ rule150={GENCAT_LL, NUMCAT_LL, 1, -10795, 0, -10795};+static const struct _convrule_ rule149={GENCAT_LU, NUMCAT_LU, 1, 0, -10727, 0};+static const struct _convrule_ rule138={GENCAT_LU, NUMCAT_LU, 1, 0, -7517, 0};+static const struct _convrule_ rule34={GENCAT_LU, NUMCAT_LU, 1, 0, 207, 0};+static const struct _convrule_ rule158={GENCAT_CO, NUMCAT_CO, 0, 0, 0, 0};+static const struct _convrule_ rule81={GENCAT_MN, NUMCAT_MN, 0, 0, 0, 0};+static const struct _convrule_ rule16={GENCAT_CF, NUMCAT_CF, 0, 0, 0, 0};+static const struct _convrule_ rule45={GENCAT_LO, NUMCAT_LO, 0, 0, 0, 0};+static const struct _convrule_ rule13={GENCAT_SO, NUMCAT_SO, 0, 0, 0, 0};+static const struct _convrule_ rule8={GENCAT_ND, NUMCAT_ND, 0, 0, 0, 0};+static const struct _convrule_ rule14={GENCAT_LL, NUMCAT_LL, 0, 0, 0, 0};+static const struct _convrule_ rule95={GENCAT_LU, NUMCAT_LU, 0, 0, 0, 0};+static const struct _convrule_ rule6={GENCAT_SM, NUMCAT_SM, 0, 0, 0, 0};+static const struct _convrule_ rule17={GENCAT_NO, NUMCAT_NO, 0, 0, 0, 0};+static const struct _convrule_ rule111={GENCAT_MC, NUMCAT_MC, 0, 0, 0, 0};+static const struct _convrule_ rule2={GENCAT_PO, NUMCAT_PO, 0, 0, 0, 0};+static const struct _convrule_ rule113={GENCAT_NL, NUMCAT_NL, 0, 0, 0, 0};+static const struct _convrule_ rule3={GENCAT_SC, NUMCAT_SC, 0, 0, 0, 0};+static const struct _convrule_ rule10={GENCAT_SK, NUMCAT_SK, 0, 0, 0, 0};+static const struct _convrule_ rule80={GENCAT_LM, NUMCAT_LM, 0, 0, 0, 0};+static const struct _convrule_ rule5={GENCAT_PE, NUMCAT_PE, 0, 0, 0, 0};+static const struct _convrule_ rule4={GENCAT_PS, NUMCAT_PS, 0, 0, 0, 0};+static const struct _convrule_ rule11={GENCAT_PC, NUMCAT_PC, 0, 0, 0, 0};+static const struct _convrule_ rule7={GENCAT_PD, NUMCAT_PD, 0, 0, 0, 0};+static const struct _convrule_ rule157={GENCAT_CS, NUMCAT_CS, 0, 0, 0, 0};+static const struct _convrule_ rule106={GENCAT_ME, NUMCAT_ME, 0, 0, 0, 0};+static const struct _convrule_ rule1={GENCAT_ZS, NUMCAT_ZS, 0, 0, 0, 0};+static const struct _convrule_ rule19={GENCAT_PF, NUMCAT_PF, 0, 0, 0, 0};+static const struct _convrule_ rule15={GENCAT_PI, NUMCAT_PI, 0, 0, 0, 0};+static const struct _convrule_ rule137={GENCAT_ZP, NUMCAT_ZP, 0, 0, 0, 0};+static const struct _convrule_ rule136={GENCAT_ZL, NUMCAT_ZL, 0, 0, 0, 0};+static const struct _convrule_ rule131={GENCAT_LU, NUMCAT_LU, 1, 0, -86, 0};+static const struct _convrule_ rule43={GENCAT_LU, NUMCAT_LU, 1, 0, 217, 0};+static const struct _convrule_ rule0={GENCAT_CC, NUMCAT_CC, 0, 0, 0, 0};+static const struct _convrule_ rule151={GENCAT_LL, NUMCAT_LL, 1, -10792, 0, -10792};+static const struct _convrule_ rule71={GENCAT_LL, NUMCAT_LL, 1, 10749, 0, 10749};+static const struct _convrule_ rule84={GENCAT_LU, NUMCAT_LU, 1, 0, 37, 0};+static const struct _convrule_ rule60={GENCAT_LL, NUMCAT_LL, 1, 10783, 0, 10783};+static const struct _convrule_ rule119={GENCAT_LU, NUMCAT_LU, 1, 0, -8, 0};+static const struct _convrule_ rule126={GENCAT_LT, NUMCAT_LT, 1, 0, -8, 0};+static const struct _convrule_ rule79={GENCAT_LL, NUMCAT_LL, 1, -219, 0, -219};+static const struct _convrule_ rule74={GENCAT_LL, NUMCAT_LL, 1, 10727, 0, 10727};+static const struct _convrule_ rule75={GENCAT_LL, NUMCAT_LL, 1, -218, 0, -218};+static const struct _convrule_ rule68={GENCAT_LL, NUMCAT_LL, 1, -209, 0, -209};+static const struct _convrule_ rule61={GENCAT_LL, NUMCAT_LL, 1, 10780, 0, 10780};+static const struct _convrule_ rule48={GENCAT_LT, NUMCAT_LT, 1, -1, 1, 0};+static const struct _convrule_ rule21={GENCAT_LU, NUMCAT_LU, 1, 0, 1, 0};+static const struct _convrule_ rule134={GENCAT_LU, NUMCAT_LU, 1, 0, -128, 0};+static const struct _convrule_ rule77={GENCAT_LL, NUMCAT_LL, 1, -217, 0, -217};+static const struct _convrule_ rule70={GENCAT_LL, NUMCAT_LL, 1, 10743, 0, 10743};+static const struct _convrule_ rule42={GENCAT_LU, NUMCAT_LU, 1, 0, 218, 0};+static const struct _convrule_ rule67={GENCAT_LL, NUMCAT_LL, 1, -207, 0, -207};+static const struct _convrule_ rule51={GENCAT_LU, NUMCAT_LU, 1, 0, -97, 0};+static const struct _convrule_ rule141={GENCAT_LU, NUMCAT_LU, 1, 0, 28, 0};+static const struct _convrule_ rule63={GENCAT_LL, NUMCAT_LL, 1, -206, 0, -206};+static const struct _convrule_ rule83={GENCAT_LU, NUMCAT_LU, 1, 0, 38, 0};+static const struct _convrule_ rule73={GENCAT_LL, NUMCAT_LL, 1, -214, 0, -214};+static const struct _convrule_ rule64={GENCAT_LL, NUMCAT_LL, 1, -205, 0, -205};+static const struct _convrule_ rule24={GENCAT_LL, NUMCAT_LL, 1, -232, 0, -232};+static const struct _convrule_ rule109={GENCAT_LU, NUMCAT_LU, 1, 0, 48, 0};+static const struct _convrule_ rule129={GENCAT_LT, NUMCAT_LT, 1, 0, -9, 0};+static const struct _convrule_ rule72={GENCAT_LL, NUMCAT_LL, 1, -213, 0, -213};+static const struct _convrule_ rule66={GENCAT_LL, NUMCAT_LL, 1, -203, 0, -203};+static const struct _convrule_ rule132={GENCAT_LU, NUMCAT_LU, 1, 0, -100, 0};+static const struct _convrule_ rule69={GENCAT_LL, NUMCAT_LL, 1, -211, 0, -211};+static const struct _convrule_ rule65={GENCAT_LL, NUMCAT_LL, 1, -202, 0, -202};+static const struct _convrule_ rule47={GENCAT_LU, NUMCAT_LU, 1, 0, 2, 1};+static const struct _convrule_ rule37={GENCAT_LU, NUMCAT_LU, 1, 0, 209, 0};+static const struct _convrule_ rule153={GENCAT_LU, NUMCAT_LU, 1, 0, -10749, 0};+static const struct _convrule_ rule62={GENCAT_LL, NUMCAT_LL, 1, -210, 0, -210};+static const struct _convrule_ rule44={GENCAT_LU, NUMCAT_LU, 1, 0, 219, 0};+static const struct _convrule_ rule28={GENCAT_LU, NUMCAT_LU, 1, 0, 210, 0};+static const struct _convrule_ rule53={GENCAT_LU, NUMCAT_LU, 1, 0, -130, 0};+static const struct _convrule_ rule159={GENCAT_LU, NUMCAT_LU, 1, 0, 40, 0};+static const struct _convrule_ rule152={GENCAT_LU, NUMCAT_LU, 1, 0, -10780, 0};+static const struct _convrule_ rule102={GENCAT_LU, NUMCAT_LU, 1, 0, -60, 0};+static const struct _convrule_ rule58={GENCAT_LU, NUMCAT_LU, 1, 0, 69, 0};+static const struct _convrule_ rule31={GENCAT_LU, NUMCAT_LU, 1, 0, 79, 0};+static const struct _convrule_ rule27={GENCAT_LL, NUMCAT_LL, 1, 195, 0, 195};+static const struct _convrule_ rule23={GENCAT_LU, NUMCAT_LU, 1, 0, -199, 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, 2, &rule13},+	{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, 1, &rule13},+	{183, 1, &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, &rule14},+	{224, 23, &rule12},+	{247, 1, &rule6},+	{248, 7, &rule12},+	{255, 1, &rule20},+	{256, 1, &rule21},+	{257, 1, &rule22},+	{258, 1, &rule21},+	{259, 1, &rule22},+	{260, 1, &rule21},+	{261, 1, &rule22},+	{262, 1, &rule21},+	{263, 1, &rule22},+	{264, 1, &rule21},+	{265, 1, &rule22},+	{266, 1, &rule21},+	{267, 1, &rule22},+	{268, 1, &rule21},+	{269, 1, &rule22},+	{270, 1, &rule21},+	{271, 1, &rule22},+	{272, 1, &rule21},+	{273, 1, &rule22},+	{274, 1, &rule21},+	{275, 1, &rule22},+	{276, 1, &rule21},+	{277, 1, &rule22},+	{278, 1, &rule21},+	{279, 1, &rule22},+	{280, 1, &rule21},+	{281, 1, &rule22},+	{282, 1, &rule21},+	{283, 1, &rule22},+	{284, 1, &rule21},+	{285, 1, &rule22},+	{286, 1, &rule21},+	{287, 1, &rule22},+	{288, 1, &rule21},+	{289, 1, &rule22},+	{290, 1, &rule21},+	{291, 1, &rule22},+	{292, 1, &rule21},+	{293, 1, &rule22},+	{294, 1, &rule21},+	{295, 1, &rule22},+	{296, 1, &rule21},+	{297, 1, &rule22},+	{298, 1, &rule21},+	{299, 1, &rule22},+	{300, 1, &rule21},+	{301, 1, &rule22},+	{302, 1, &rule21},+	{303, 1, &rule22},+	{304, 1, &rule23},+	{305, 1, &rule24},+	{306, 1, &rule21},+	{307, 1, &rule22},+	{308, 1, &rule21},+	{309, 1, &rule22},+	{310, 1, &rule21},+	{311, 1, &rule22},+	{312, 1, &rule14},+	{313, 1, &rule21},+	{314, 1, &rule22},+	{315, 1, &rule21},+	{316, 1, &rule22},+	{317, 1, &rule21},+	{318, 1, &rule22},+	{319, 1, &rule21},+	{320, 1, &rule22},+	{321, 1, &rule21},+	{322, 1, &rule22},+	{323, 1, &rule21},+	{324, 1, &rule22},+	{325, 1, &rule21},+	{326, 1, &rule22},+	{327, 1, &rule21},+	{328, 1, &rule22},+	{329, 1, &rule14},+	{330, 1, &rule21},+	{331, 1, &rule22},+	{332, 1, &rule21},+	{333, 1, &rule22},+	{334, 1, &rule21},+	{335, 1, &rule22},+	{336, 1, &rule21},+	{337, 1, &rule22},+	{338, 1, &rule21},+	{339, 1, &rule22},+	{340, 1, &rule21},+	{341, 1, &rule22},+	{342, 1, &rule21},+	{343, 1, &rule22},+	{344, 1, &rule21},+	{345, 1, &rule22},+	{346, 1, &rule21},+	{347, 1, &rule22},+	{348, 1, &rule21},+	{349, 1, &rule22},+	{350, 1, &rule21},+	{351, 1, &rule22},+	{352, 1, &rule21},+	{353, 1, &rule22},+	{354, 1, &rule21},+	{355, 1, &rule22},+	{356, 1, &rule21},+	{357, 1, &rule22},+	{358, 1, &rule21},+	{359, 1, &rule22},+	{360, 1, &rule21},+	{361, 1, &rule22},+	{362, 1, &rule21},+	{363, 1, &rule22},+	{364, 1, &rule21},+	{365, 1, &rule22},+	{366, 1, &rule21},+	{367, 1, &rule22},+	{368, 1, &rule21},+	{369, 1, &rule22},+	{370, 1, &rule21},+	{371, 1, &rule22},+	{372, 1, &rule21},+	{373, 1, &rule22},+	{374, 1, &rule21},+	{375, 1, &rule22},+	{376, 1, &rule25},+	{377, 1, &rule21},+	{378, 1, &rule22},+	{379, 1, &rule21},+	{380, 1, &rule22},+	{381, 1, &rule21},+	{382, 1, &rule22},+	{383, 1, &rule26},+	{384, 1, &rule27},+	{385, 1, &rule28},+	{386, 1, &rule21},+	{387, 1, &rule22},+	{388, 1, &rule21},+	{389, 1, &rule22},+	{390, 1, &rule29},+	{391, 1, &rule21},+	{392, 1, &rule22},+	{393, 2, &rule30},+	{395, 1, &rule21},+	{396, 1, &rule22},+	{397, 1, &rule14},+	{398, 1, &rule31},+	{399, 1, &rule32},+	{400, 1, &rule33},+	{401, 1, &rule21},+	{402, 1, &rule22},+	{403, 1, &rule30},+	{404, 1, &rule34},+	{405, 1, &rule35},+	{406, 1, &rule36},+	{407, 1, &rule37},+	{408, 1, &rule21},+	{409, 1, &rule22},+	{410, 1, &rule38},+	{411, 1, &rule14},+	{412, 1, &rule36},+	{413, 1, &rule39},+	{414, 1, &rule40},+	{415, 1, &rule41},+	{416, 1, &rule21},+	{417, 1, &rule22},+	{418, 1, &rule21},+	{419, 1, &rule22},+	{420, 1, &rule21},+	{421, 1, &rule22},+	{422, 1, &rule42},+	{423, 1, &rule21},+	{424, 1, &rule22},+	{425, 1, &rule42},+	{426, 2, &rule14},+	{428, 1, &rule21},+	{429, 1, &rule22},+	{430, 1, &rule42},+	{431, 1, &rule21},+	{432, 1, &rule22},+	{433, 2, &rule43},+	{435, 1, &rule21},+	{436, 1, &rule22},+	{437, 1, &rule21},+	{438, 1, &rule22},+	{439, 1, &rule44},+	{440, 1, &rule21},+	{441, 1, &rule22},+	{442, 1, &rule14},+	{443, 1, &rule45},+	{444, 1, &rule21},+	{445, 1, &rule22},+	{446, 1, &rule14},+	{447, 1, &rule46},+	{448, 4, &rule45},+	{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, &rule21},+	{462, 1, &rule22},+	{463, 1, &rule21},+	{464, 1, &rule22},+	{465, 1, &rule21},+	{466, 1, &rule22},+	{467, 1, &rule21},+	{468, 1, &rule22},+	{469, 1, &rule21},+	{470, 1, &rule22},+	{471, 1, &rule21},+	{472, 1, &rule22},+	{473, 1, &rule21},+	{474, 1, &rule22},+	{475, 1, &rule21},+	{476, 1, &rule22},+	{477, 1, &rule50},+	{478, 1, &rule21},+	{479, 1, &rule22},+	{480, 1, &rule21},+	{481, 1, &rule22},+	{482, 1, &rule21},+	{483, 1, &rule22},+	{484, 1, &rule21},+	{485, 1, &rule22},+	{486, 1, &rule21},+	{487, 1, &rule22},+	{488, 1, &rule21},+	{489, 1, &rule22},+	{490, 1, &rule21},+	{491, 1, &rule22},+	{492, 1, &rule21},+	{493, 1, &rule22},+	{494, 1, &rule21},+	{495, 1, &rule22},+	{496, 1, &rule14},+	{497, 1, &rule47},+	{498, 1, &rule48},+	{499, 1, &rule49},+	{500, 1, &rule21},+	{501, 1, &rule22},+	{502, 1, &rule51},+	{503, 1, &rule52},+	{504, 1, &rule21},+	{505, 1, &rule22},+	{506, 1, &rule21},+	{507, 1, &rule22},+	{508, 1, &rule21},+	{509, 1, &rule22},+	{510, 1, &rule21},+	{511, 1, &rule22},+	{512, 1, &rule21},+	{513, 1, &rule22},+	{514, 1, &rule21},+	{515, 1, &rule22},+	{516, 1, &rule21},+	{517, 1, &rule22},+	{518, 1, &rule21},+	{519, 1, &rule22},+	{520, 1, &rule21},+	{521, 1, &rule22},+	{522, 1, &rule21},+	{523, 1, &rule22},+	{524, 1, &rule21},+	{525, 1, &rule22},+	{526, 1, &rule21},+	{527, 1, &rule22},+	{528, 1, &rule21},+	{529, 1, &rule22},+	{530, 1, &rule21},+	{531, 1, &rule22},+	{532, 1, &rule21},+	{533, 1, &rule22},+	{534, 1, &rule21},+	{535, 1, &rule22},+	{536, 1, &rule21},+	{537, 1, &rule22},+	{538, 1, &rule21},+	{539, 1, &rule22},+	{540, 1, &rule21},+	{541, 1, &rule22},+	{542, 1, &rule21},+	{543, 1, &rule22},+	{544, 1, &rule53},+	{545, 1, &rule14},+	{546, 1, &rule21},+	{547, 1, &rule22},+	{548, 1, &rule21},+	{549, 1, &rule22},+	{550, 1, &rule21},+	{551, 1, &rule22},+	{552, 1, &rule21},+	{553, 1, &rule22},+	{554, 1, &rule21},+	{555, 1, &rule22},+	{556, 1, &rule21},+	{557, 1, &rule22},+	{558, 1, &rule21},+	{559, 1, &rule22},+	{560, 1, &rule21},+	{561, 1, &rule22},+	{562, 1, &rule21},+	{563, 1, &rule22},+	{564, 6, &rule14},+	{570, 1, &rule54},+	{571, 1, &rule21},+	{572, 1, &rule22},+	{573, 1, &rule55},+	{574, 1, &rule56},+	{575, 2, &rule14},+	{577, 1, &rule21},+	{578, 1, &rule22},+	{579, 1, &rule57},+	{580, 1, &rule58},+	{581, 1, &rule59},+	{582, 1, &rule21},+	{583, 1, &rule22},+	{584, 1, &rule21},+	{585, 1, &rule22},+	{586, 1, &rule21},+	{587, 1, &rule22},+	{588, 1, &rule21},+	{589, 1, &rule22},+	{590, 1, &rule21},+	{591, 1, &rule22},+	{592, 1, &rule60},+	{593, 1, &rule61},+	{594, 1, &rule14},+	{595, 1, &rule62},+	{596, 1, &rule63},+	{597, 1, &rule14},+	{598, 2, &rule64},+	{600, 1, &rule14},+	{601, 1, &rule65},+	{602, 1, &rule14},+	{603, 1, &rule66},+	{604, 4, &rule14},+	{608, 1, &rule64},+	{609, 2, &rule14},+	{611, 1, &rule67},+	{612, 4, &rule14},+	{616, 1, &rule68},+	{617, 1, &rule69},+	{618, 1, &rule14},+	{619, 1, &rule70},+	{620, 3, &rule14},+	{623, 1, &rule69},+	{624, 1, &rule14},+	{625, 1, &rule71},+	{626, 1, &rule72},+	{627, 2, &rule14},+	{629, 1, &rule73},+	{630, 7, &rule14},+	{637, 1, &rule74},+	{638, 2, &rule14},+	{640, 1, &rule75},+	{641, 2, &rule14},+	{643, 1, &rule75},+	{644, 4, &rule14},+	{648, 1, &rule75},+	{649, 1, &rule76},+	{650, 2, &rule77},+	{652, 1, &rule78},+	{653, 5, &rule14},+	{658, 1, &rule79},+	{659, 1, &rule14},+	{660, 1, &rule45},+	{661, 27, &rule14},+	{688, 18, &rule80},+	{706, 4, &rule10},+	{710, 12, &rule80},+	{722, 14, &rule10},+	{736, 5, &rule80},+	{741, 7, &rule10},+	{748, 1, &rule80},+	{749, 1, &rule10},+	{750, 1, &rule80},+	{751, 17, &rule10},+	{768, 69, &rule81},+	{837, 1, &rule82},+	{838, 42, &rule81},+	{880, 1, &rule21},+	{881, 1, &rule22},+	{882, 1, &rule21},+	{883, 1, &rule22},+	{884, 1, &rule80},+	{885, 1, &rule10},+	{886, 1, &rule21},+	{887, 1, &rule22},+	{890, 1, &rule80},+	{891, 3, &rule40},+	{894, 1, &rule2},+	{900, 2, &rule10},+	{902, 1, &rule83},+	{903, 1, &rule2},+	{904, 3, &rule84},+	{908, 1, &rule85},+	{910, 2, &rule86},+	{912, 1, &rule14},+	{913, 17, &rule9},+	{931, 9, &rule9},+	{940, 1, &rule87},+	{941, 3, &rule88},+	{944, 1, &rule14},+	{945, 17, &rule12},+	{962, 1, &rule89},+	{963, 9, &rule12},+	{972, 1, &rule90},+	{973, 2, &rule91},+	{975, 1, &rule92},+	{976, 1, &rule93},+	{977, 1, &rule94},+	{978, 3, &rule95},+	{981, 1, &rule96},+	{982, 1, &rule97},+	{983, 1, &rule98},+	{984, 1, &rule21},+	{985, 1, &rule22},+	{986, 1, &rule21},+	{987, 1, &rule22},+	{988, 1, &rule21},+	{989, 1, &rule22},+	{990, 1, &rule21},+	{991, 1, &rule22},+	{992, 1, &rule21},+	{993, 1, &rule22},+	{994, 1, &rule21},+	{995, 1, &rule22},+	{996, 1, &rule21},+	{997, 1, &rule22},+	{998, 1, &rule21},+	{999, 1, &rule22},+	{1000, 1, &rule21},+	{1001, 1, &rule22},+	{1002, 1, &rule21},+	{1003, 1, &rule22},+	{1004, 1, &rule21},+	{1005, 1, &rule22},+	{1006, 1, &rule21},+	{1007, 1, &rule22},+	{1008, 1, &rule99},+	{1009, 1, &rule100},+	{1010, 1, &rule101},+	{1011, 1, &rule14},+	{1012, 1, &rule102},+	{1013, 1, &rule103},+	{1014, 1, &rule6},+	{1015, 1, &rule21},+	{1016, 1, &rule22},+	{1017, 1, &rule104},+	{1018, 1, &rule21},+	{1019, 1, &rule22},+	{1020, 1, &rule14},+	{1021, 3, &rule53},+	{1024, 16, &rule105},+	{1040, 32, &rule9},+	{1072, 32, &rule12},+	{1104, 16, &rule100},+	{1120, 1, &rule21},+	{1121, 1, &rule22},+	{1122, 1, &rule21},+	{1123, 1, &rule22},+	{1124, 1, &rule21},+	{1125, 1, &rule22},+	{1126, 1, &rule21},+	{1127, 1, &rule22},+	{1128, 1, &rule21},+	{1129, 1, &rule22},+	{1130, 1, &rule21},+	{1131, 1, &rule22},+	{1132, 1, &rule21},+	{1133, 1, &rule22},+	{1134, 1, &rule21},+	{1135, 1, &rule22},+	{1136, 1, &rule21},+	{1137, 1, &rule22},+	{1138, 1, &rule21},+	{1139, 1, &rule22},+	{1140, 1, &rule21},+	{1141, 1, &rule22},+	{1142, 1, &rule21},+	{1143, 1, &rule22},+	{1144, 1, &rule21},+	{1145, 1, &rule22},+	{1146, 1, &rule21},+	{1147, 1, &rule22},+	{1148, 1, &rule21},+	{1149, 1, &rule22},+	{1150, 1, &rule21},+	{1151, 1, &rule22},+	{1152, 1, &rule21},+	{1153, 1, &rule22},+	{1154, 1, &rule13},+	{1155, 5, &rule81},+	{1160, 2, &rule106},+	{1162, 1, &rule21},+	{1163, 1, &rule22},+	{1164, 1, &rule21},+	{1165, 1, &rule22},+	{1166, 1, &rule21},+	{1167, 1, &rule22},+	{1168, 1, &rule21},+	{1169, 1, &rule22},+	{1170, 1, &rule21},+	{1171, 1, &rule22},+	{1172, 1, &rule21},+	{1173, 1, &rule22},+	{1174, 1, &rule21},+	{1175, 1, &rule22},+	{1176, 1, &rule21},+	{1177, 1, &rule22},+	{1178, 1, &rule21},+	{1179, 1, &rule22},+	{1180, 1, &rule21},+	{1181, 1, &rule22},+	{1182, 1, &rule21},+	{1183, 1, &rule22},+	{1184, 1, &rule21},+	{1185, 1, &rule22},+	{1186, 1, &rule21},+	{1187, 1, &rule22},+	{1188, 1, &rule21},+	{1189, 1, &rule22},+	{1190, 1, &rule21},+	{1191, 1, &rule22},+	{1192, 1, &rule21},+	{1193, 1, &rule22},+	{1194, 1, &rule21},+	{1195, 1, &rule22},+	{1196, 1, &rule21},+	{1197, 1, &rule22},+	{1198, 1, &rule21},+	{1199, 1, &rule22},+	{1200, 1, &rule21},+	{1201, 1, &rule22},+	{1202, 1, &rule21},+	{1203, 1, &rule22},+	{1204, 1, &rule21},+	{1205, 1, &rule22},+	{1206, 1, &rule21},+	{1207, 1, &rule22},+	{1208, 1, &rule21},+	{1209, 1, &rule22},+	{1210, 1, &rule21},+	{1211, 1, &rule22},+	{1212, 1, &rule21},+	{1213, 1, &rule22},+	{1214, 1, &rule21},+	{1215, 1, &rule22},+	{1216, 1, &rule107},+	{1217, 1, &rule21},+	{1218, 1, &rule22},+	{1219, 1, &rule21},+	{1220, 1, &rule22},+	{1221, 1, &rule21},+	{1222, 1, &rule22},+	{1223, 1, &rule21},+	{1224, 1, &rule22},+	{1225, 1, &rule21},+	{1226, 1, &rule22},+	{1227, 1, &rule21},+	{1228, 1, &rule22},+	{1229, 1, &rule21},+	{1230, 1, &rule22},+	{1231, 1, &rule108},+	{1232, 1, &rule21},+	{1233, 1, &rule22},+	{1234, 1, &rule21},+	{1235, 1, &rule22},+	{1236, 1, &rule21},+	{1237, 1, &rule22},+	{1238, 1, &rule21},+	{1239, 1, &rule22},+	{1240, 1, &rule21},+	{1241, 1, &rule22},+	{1242, 1, &rule21},+	{1243, 1, &rule22},+	{1244, 1, &rule21},+	{1245, 1, &rule22},+	{1246, 1, &rule21},+	{1247, 1, &rule22},+	{1248, 1, &rule21},+	{1249, 1, &rule22},+	{1250, 1, &rule21},+	{1251, 1, &rule22},+	{1252, 1, &rule21},+	{1253, 1, &rule22},+	{1254, 1, &rule21},+	{1255, 1, &rule22},+	{1256, 1, &rule21},+	{1257, 1, &rule22},+	{1258, 1, &rule21},+	{1259, 1, &rule22},+	{1260, 1, &rule21},+	{1261, 1, &rule22},+	{1262, 1, &rule21},+	{1263, 1, &rule22},+	{1264, 1, &rule21},+	{1265, 1, &rule22},+	{1266, 1, &rule21},+	{1267, 1, &rule22},+	{1268, 1, &rule21},+	{1269, 1, &rule22},+	{1270, 1, &rule21},+	{1271, 1, &rule22},+	{1272, 1, &rule21},+	{1273, 1, &rule22},+	{1274, 1, &rule21},+	{1275, 1, &rule22},+	{1276, 1, &rule21},+	{1277, 1, &rule22},+	{1278, 1, &rule21},+	{1279, 1, &rule22},+	{1280, 1, &rule21},+	{1281, 1, &rule22},+	{1282, 1, &rule21},+	{1283, 1, &rule22},+	{1284, 1, &rule21},+	{1285, 1, &rule22},+	{1286, 1, &rule21},+	{1287, 1, &rule22},+	{1288, 1, &rule21},+	{1289, 1, &rule22},+	{1290, 1, &rule21},+	{1291, 1, &rule22},+	{1292, 1, &rule21},+	{1293, 1, &rule22},+	{1294, 1, &rule21},+	{1295, 1, &rule22},+	{1296, 1, &rule21},+	{1297, 1, &rule22},+	{1298, 1, &rule21},+	{1299, 1, &rule22},+	{1300, 1, &rule21},+	{1301, 1, &rule22},+	{1302, 1, &rule21},+	{1303, 1, &rule22},+	{1304, 1, &rule21},+	{1305, 1, &rule22},+	{1306, 1, &rule21},+	{1307, 1, &rule22},+	{1308, 1, &rule21},+	{1309, 1, &rule22},+	{1310, 1, &rule21},+	{1311, 1, &rule22},+	{1312, 1, &rule21},+	{1313, 1, &rule22},+	{1314, 1, &rule21},+	{1315, 1, &rule22},+	{1329, 38, &rule109},+	{1369, 1, &rule80},+	{1370, 6, &rule2},+	{1377, 38, &rule110},+	{1415, 1, &rule14},+	{1417, 1, &rule2},+	{1418, 1, &rule7},+	{1425, 45, &rule81},+	{1470, 1, &rule7},+	{1471, 1, &rule81},+	{1472, 1, &rule2},+	{1473, 2, &rule81},+	{1475, 1, &rule2},+	{1476, 2, &rule81},+	{1478, 1, &rule2},+	{1479, 1, &rule81},+	{1488, 27, &rule45},+	{1520, 3, &rule45},+	{1523, 2, &rule2},+	{1536, 4, &rule16},+	{1542, 3, &rule6},+	{1545, 2, &rule2},+	{1547, 1, &rule3},+	{1548, 2, &rule2},+	{1550, 2, &rule13},+	{1552, 11, &rule81},+	{1563, 1, &rule2},+	{1566, 2, &rule2},+	{1569, 31, &rule45},+	{1600, 1, &rule80},+	{1601, 10, &rule45},+	{1611, 20, &rule81},+	{1632, 10, &rule8},+	{1642, 4, &rule2},+	{1646, 2, &rule45},+	{1648, 1, &rule81},+	{1649, 99, &rule45},+	{1748, 1, &rule2},+	{1749, 1, &rule45},+	{1750, 7, &rule81},+	{1757, 1, &rule16},+	{1758, 1, &rule106},+	{1759, 6, &rule81},+	{1765, 2, &rule80},+	{1767, 2, &rule81},+	{1769, 1, &rule13},+	{1770, 4, &rule81},+	{1774, 2, &rule45},+	{1776, 10, &rule8},+	{1786, 3, &rule45},+	{1789, 2, &rule13},+	{1791, 1, &rule45},+	{1792, 14, &rule2},+	{1807, 1, &rule16},+	{1808, 1, &rule45},+	{1809, 1, &rule81},+	{1810, 30, &rule45},+	{1840, 27, &rule81},+	{1869, 89, &rule45},+	{1958, 11, &rule81},+	{1969, 1, &rule45},+	{1984, 10, &rule8},+	{1994, 33, &rule45},+	{2027, 9, &rule81},+	{2036, 2, &rule80},+	{2038, 1, &rule13},+	{2039, 3, &rule2},+	{2042, 1, &rule80},+	{2305, 2, &rule81},+	{2307, 1, &rule111},+	{2308, 54, &rule45},+	{2364, 1, &rule81},+	{2365, 1, &rule45},+	{2366, 3, &rule111},+	{2369, 8, &rule81},+	{2377, 4, &rule111},+	{2381, 1, &rule81},+	{2384, 1, &rule45},+	{2385, 4, &rule81},+	{2392, 10, &rule45},+	{2402, 2, &rule81},+	{2404, 2, &rule2},+	{2406, 10, &rule8},+	{2416, 1, &rule2},+	{2417, 1, &rule80},+	{2418, 1, &rule45},+	{2427, 5, &rule45},+	{2433, 1, &rule81},+	{2434, 2, &rule111},+	{2437, 8, &rule45},+	{2447, 2, &rule45},+	{2451, 22, &rule45},+	{2474, 7, &rule45},+	{2482, 1, &rule45},+	{2486, 4, &rule45},+	{2492, 1, &rule81},+	{2493, 1, &rule45},+	{2494, 3, &rule111},+	{2497, 4, &rule81},+	{2503, 2, &rule111},+	{2507, 2, &rule111},+	{2509, 1, &rule81},+	{2510, 1, &rule45},+	{2519, 1, &rule111},+	{2524, 2, &rule45},+	{2527, 3, &rule45},+	{2530, 2, &rule81},+	{2534, 10, &rule8},+	{2544, 2, &rule45},+	{2546, 2, &rule3},+	{2548, 6, &rule17},+	{2554, 1, &rule13},+	{2561, 2, &rule81},+	{2563, 1, &rule111},+	{2565, 6, &rule45},+	{2575, 2, &rule45},+	{2579, 22, &rule45},+	{2602, 7, &rule45},+	{2610, 2, &rule45},+	{2613, 2, &rule45},+	{2616, 2, &rule45},+	{2620, 1, &rule81},+	{2622, 3, &rule111},+	{2625, 2, &rule81},+	{2631, 2, &rule81},+	{2635, 3, &rule81},+	{2641, 1, &rule81},+	{2649, 4, &rule45},+	{2654, 1, &rule45},+	{2662, 10, &rule8},+	{2672, 2, &rule81},+	{2674, 3, &rule45},+	{2677, 1, &rule81},+	{2689, 2, &rule81},+	{2691, 1, &rule111},+	{2693, 9, &rule45},+	{2703, 3, &rule45},+	{2707, 22, &rule45},+	{2730, 7, &rule45},+	{2738, 2, &rule45},+	{2741, 5, &rule45},+	{2748, 1, &rule81},+	{2749, 1, &rule45},+	{2750, 3, &rule111},+	{2753, 5, &rule81},+	{2759, 2, &rule81},+	{2761, 1, &rule111},+	{2763, 2, &rule111},+	{2765, 1, &rule81},+	{2768, 1, &rule45},+	{2784, 2, &rule45},+	{2786, 2, &rule81},+	{2790, 10, &rule8},+	{2801, 1, &rule3},+	{2817, 1, &rule81},+	{2818, 2, &rule111},+	{2821, 8, &rule45},+	{2831, 2, &rule45},+	{2835, 22, &rule45},+	{2858, 7, &rule45},+	{2866, 2, &rule45},+	{2869, 5, &rule45},+	{2876, 1, &rule81},+	{2877, 1, &rule45},+	{2878, 1, &rule111},+	{2879, 1, &rule81},+	{2880, 1, &rule111},+	{2881, 4, &rule81},+	{2887, 2, &rule111},+	{2891, 2, &rule111},+	{2893, 1, &rule81},+	{2902, 1, &rule81},+	{2903, 1, &rule111},+	{2908, 2, &rule45},+	{2911, 3, &rule45},+	{2914, 2, &rule81},+	{2918, 10, &rule8},+	{2928, 1, &rule13},+	{2929, 1, &rule45},+	{2946, 1, &rule81},+	{2947, 1, &rule45},+	{2949, 6, &rule45},+	{2958, 3, &rule45},+	{2962, 4, &rule45},+	{2969, 2, &rule45},+	{2972, 1, &rule45},+	{2974, 2, &rule45},+	{2979, 2, &rule45},+	{2984, 3, &rule45},+	{2990, 12, &rule45},+	{3006, 2, &rule111},+	{3008, 1, &rule81},+	{3009, 2, &rule111},+	{3014, 3, &rule111},+	{3018, 3, &rule111},+	{3021, 1, &rule81},+	{3024, 1, &rule45},+	{3031, 1, &rule111},+	{3046, 10, &rule8},+	{3056, 3, &rule17},+	{3059, 6, &rule13},+	{3065, 1, &rule3},+	{3066, 1, &rule13},+	{3073, 3, &rule111},+	{3077, 8, &rule45},+	{3086, 3, &rule45},+	{3090, 23, &rule45},+	{3114, 10, &rule45},+	{3125, 5, &rule45},+	{3133, 1, &rule45},+	{3134, 3, &rule81},+	{3137, 4, &rule111},+	{3142, 3, &rule81},+	{3146, 4, &rule81},+	{3157, 2, &rule81},+	{3160, 2, &rule45},+	{3168, 2, &rule45},+	{3170, 2, &rule81},+	{3174, 10, &rule8},+	{3192, 7, &rule17},+	{3199, 1, &rule13},+	{3202, 2, &rule111},+	{3205, 8, &rule45},+	{3214, 3, &rule45},+	{3218, 23, &rule45},+	{3242, 10, &rule45},+	{3253, 5, &rule45},+	{3260, 1, &rule81},+	{3261, 1, &rule45},+	{3262, 1, &rule111},+	{3263, 1, &rule81},+	{3264, 5, &rule111},+	{3270, 1, &rule81},+	{3271, 2, &rule111},+	{3274, 2, &rule111},+	{3276, 2, &rule81},+	{3285, 2, &rule111},+	{3294, 1, &rule45},+	{3296, 2, &rule45},+	{3298, 2, &rule81},+	{3302, 10, &rule8},+	{3313, 2, &rule13},+	{3330, 2, &rule111},+	{3333, 8, &rule45},+	{3342, 3, &rule45},+	{3346, 23, &rule45},+	{3370, 16, &rule45},+	{3389, 1, &rule45},+	{3390, 3, &rule111},+	{3393, 4, &rule81},+	{3398, 3, &rule111},+	{3402, 3, &rule111},+	{3405, 1, &rule81},+	{3415, 1, &rule111},+	{3424, 2, &rule45},+	{3426, 2, &rule81},+	{3430, 10, &rule8},+	{3440, 6, &rule17},+	{3449, 1, &rule13},+	{3450, 6, &rule45},+	{3458, 2, &rule111},+	{3461, 18, &rule45},+	{3482, 24, &rule45},+	{3507, 9, &rule45},+	{3517, 1, &rule45},+	{3520, 7, &rule45},+	{3530, 1, &rule81},+	{3535, 3, &rule111},+	{3538, 3, &rule81},+	{3542, 1, &rule81},+	{3544, 8, &rule111},+	{3570, 2, &rule111},+	{3572, 1, &rule2},+	{3585, 48, &rule45},+	{3633, 1, &rule81},+	{3634, 2, &rule45},+	{3636, 7, &rule81},+	{3647, 1, &rule3},+	{3648, 6, &rule45},+	{3654, 1, &rule80},+	{3655, 8, &rule81},+	{3663, 1, &rule2},+	{3664, 10, &rule8},+	{3674, 2, &rule2},+	{3713, 2, &rule45},+	{3716, 1, &rule45},+	{3719, 2, &rule45},+	{3722, 1, &rule45},+	{3725, 1, &rule45},+	{3732, 4, &rule45},+	{3737, 7, &rule45},+	{3745, 3, &rule45},+	{3749, 1, &rule45},+	{3751, 1, &rule45},+	{3754, 2, &rule45},+	{3757, 4, &rule45},+	{3761, 1, &rule81},+	{3762, 2, &rule45},+	{3764, 6, &rule81},+	{3771, 2, &rule81},+	{3773, 1, &rule45},+	{3776, 5, &rule45},+	{3782, 1, &rule80},+	{3784, 6, &rule81},+	{3792, 10, &rule8},+	{3804, 2, &rule45},+	{3840, 1, &rule45},+	{3841, 3, &rule13},+	{3844, 15, &rule2},+	{3859, 5, &rule13},+	{3864, 2, &rule81},+	{3866, 6, &rule13},+	{3872, 10, &rule8},+	{3882, 10, &rule17},+	{3892, 1, &rule13},+	{3893, 1, &rule81},+	{3894, 1, &rule13},+	{3895, 1, &rule81},+	{3896, 1, &rule13},+	{3897, 1, &rule81},+	{3898, 1, &rule4},+	{3899, 1, &rule5},+	{3900, 1, &rule4},+	{3901, 1, &rule5},+	{3902, 2, &rule111},+	{3904, 8, &rule45},+	{3913, 36, &rule45},+	{3953, 14, &rule81},+	{3967, 1, &rule111},+	{3968, 5, &rule81},+	{3973, 1, &rule2},+	{3974, 2, &rule81},+	{3976, 4, &rule45},+	{3984, 8, &rule81},+	{3993, 36, &rule81},+	{4030, 8, &rule13},+	{4038, 1, &rule81},+	{4039, 6, &rule13},+	{4046, 2, &rule13},+	{4048, 5, &rule2},+	{4096, 43, &rule45},+	{4139, 2, &rule111},+	{4141, 4, &rule81},+	{4145, 1, &rule111},+	{4146, 6, &rule81},+	{4152, 1, &rule111},+	{4153, 2, &rule81},+	{4155, 2, &rule111},+	{4157, 2, &rule81},+	{4159, 1, &rule45},+	{4160, 10, &rule8},+	{4170, 6, &rule2},+	{4176, 6, &rule45},+	{4182, 2, &rule111},+	{4184, 2, &rule81},+	{4186, 4, &rule45},+	{4190, 3, &rule81},+	{4193, 1, &rule45},+	{4194, 3, &rule111},+	{4197, 2, &rule45},+	{4199, 7, &rule111},+	{4206, 3, &rule45},+	{4209, 4, &rule81},+	{4213, 13, &rule45},+	{4226, 1, &rule81},+	{4227, 2, &rule111},+	{4229, 2, &rule81},+	{4231, 6, &rule111},+	{4237, 1, &rule81},+	{4238, 1, &rule45},+	{4239, 1, &rule111},+	{4240, 10, &rule8},+	{4254, 2, &rule13},+	{4256, 38, &rule112},+	{4304, 43, &rule45},+	{4347, 1, &rule2},+	{4348, 1, &rule80},+	{4352, 90, &rule45},+	{4447, 68, &rule45},+	{4520, 82, &rule45},+	{4608, 73, &rule45},+	{4682, 4, &rule45},+	{4688, 7, &rule45},+	{4696, 1, &rule45},+	{4698, 4, &rule45},+	{4704, 41, &rule45},+	{4746, 4, &rule45},+	{4752, 33, &rule45},+	{4786, 4, &rule45},+	{4792, 7, &rule45},+	{4800, 1, &rule45},+	{4802, 4, &rule45},+	{4808, 15, &rule45},+	{4824, 57, &rule45},+	{4882, 4, &rule45},+	{4888, 67, &rule45},+	{4959, 1, &rule81},+	{4960, 1, &rule13},+	{4961, 8, &rule2},+	{4969, 20, &rule17},+	{4992, 16, &rule45},+	{5008, 10, &rule13},+	{5024, 85, &rule45},+	{5121, 620, &rule45},+	{5741, 2, &rule2},+	{5743, 8, &rule45},+	{5760, 1, &rule1},+	{5761, 26, &rule45},+	{5787, 1, &rule4},+	{5788, 1, &rule5},+	{5792, 75, &rule45},+	{5867, 3, &rule2},+	{5870, 3, &rule113},+	{5888, 13, &rule45},+	{5902, 4, &rule45},+	{5906, 3, &rule81},+	{5920, 18, &rule45},+	{5938, 3, &rule81},+	{5941, 2, &rule2},+	{5952, 18, &rule45},+	{5970, 2, &rule81},+	{5984, 13, &rule45},+	{5998, 3, &rule45},+	{6002, 2, &rule81},+	{6016, 52, &rule45},+	{6068, 2, &rule16},+	{6070, 1, &rule111},+	{6071, 7, &rule81},+	{6078, 8, &rule111},+	{6086, 1, &rule81},+	{6087, 2, &rule111},+	{6089, 11, &rule81},+	{6100, 3, &rule2},+	{6103, 1, &rule80},+	{6104, 3, &rule2},+	{6107, 1, &rule3},+	{6108, 1, &rule45},+	{6109, 1, &rule81},+	{6112, 10, &rule8},+	{6128, 10, &rule17},+	{6144, 6, &rule2},+	{6150, 1, &rule7},+	{6151, 4, &rule2},+	{6155, 3, &rule81},+	{6158, 1, &rule1},+	{6160, 10, &rule8},+	{6176, 35, &rule45},+	{6211, 1, &rule80},+	{6212, 52, &rule45},+	{6272, 41, &rule45},+	{6313, 1, &rule81},+	{6314, 1, &rule45},+	{6400, 29, &rule45},+	{6432, 3, &rule81},+	{6435, 4, &rule111},+	{6439, 2, &rule81},+	{6441, 3, &rule111},+	{6448, 2, &rule111},+	{6450, 1, &rule81},+	{6451, 6, &rule111},+	{6457, 3, &rule81},+	{6464, 1, &rule13},+	{6468, 2, &rule2},+	{6470, 10, &rule8},+	{6480, 30, &rule45},+	{6512, 5, &rule45},+	{6528, 42, &rule45},+	{6576, 17, &rule111},+	{6593, 7, &rule45},+	{6600, 2, &rule111},+	{6608, 10, &rule8},+	{6622, 2, &rule2},+	{6624, 32, &rule13},+	{6656, 23, &rule45},+	{6679, 2, &rule81},+	{6681, 3, &rule111},+	{6686, 2, &rule2},+	{6912, 4, &rule81},+	{6916, 1, &rule111},+	{6917, 47, &rule45},+	{6964, 1, &rule81},+	{6965, 1, &rule111},+	{6966, 5, &rule81},+	{6971, 1, &rule111},+	{6972, 1, &rule81},+	{6973, 5, &rule111},+	{6978, 1, &rule81},+	{6979, 2, &rule111},+	{6981, 7, &rule45},+	{6992, 10, &rule8},+	{7002, 7, &rule2},+	{7009, 10, &rule13},+	{7019, 9, &rule81},+	{7028, 9, &rule13},+	{7040, 2, &rule81},+	{7042, 1, &rule111},+	{7043, 30, &rule45},+	{7073, 1, &rule111},+	{7074, 4, &rule81},+	{7078, 2, &rule111},+	{7080, 2, &rule81},+	{7082, 1, &rule111},+	{7086, 2, &rule45},+	{7088, 10, &rule8},+	{7168, 36, &rule45},+	{7204, 8, &rule111},+	{7212, 8, &rule81},+	{7220, 2, &rule111},+	{7222, 2, &rule81},+	{7227, 5, &rule2},+	{7232, 10, &rule8},+	{7245, 3, &rule45},+	{7248, 10, &rule8},+	{7258, 30, &rule45},+	{7288, 6, &rule80},+	{7294, 2, &rule2},+	{7424, 44, &rule14},+	{7468, 54, &rule80},+	{7522, 22, &rule14},+	{7544, 1, &rule80},+	{7545, 1, &rule114},+	{7546, 3, &rule14},+	{7549, 1, &rule115},+	{7550, 29, &rule14},+	{7579, 37, &rule80},+	{7616, 39, &rule81},+	{7678, 2, &rule81},+	{7680, 1, &rule21},+	{7681, 1, &rule22},+	{7682, 1, &rule21},+	{7683, 1, &rule22},+	{7684, 1, &rule21},+	{7685, 1, &rule22},+	{7686, 1, &rule21},+	{7687, 1, &rule22},+	{7688, 1, &rule21},+	{7689, 1, &rule22},+	{7690, 1, &rule21},+	{7691, 1, &rule22},+	{7692, 1, &rule21},+	{7693, 1, &rule22},+	{7694, 1, &rule21},+	{7695, 1, &rule22},+	{7696, 1, &rule21},+	{7697, 1, &rule22},+	{7698, 1, &rule21},+	{7699, 1, &rule22},+	{7700, 1, &rule21},+	{7701, 1, &rule22},+	{7702, 1, &rule21},+	{7703, 1, &rule22},+	{7704, 1, &rule21},+	{7705, 1, &rule22},+	{7706, 1, &rule21},+	{7707, 1, &rule22},+	{7708, 1, &rule21},+	{7709, 1, &rule22},+	{7710, 1, &rule21},+	{7711, 1, &rule22},+	{7712, 1, &rule21},+	{7713, 1, &rule22},+	{7714, 1, &rule21},+	{7715, 1, &rule22},+	{7716, 1, &rule21},+	{7717, 1, &rule22},+	{7718, 1, &rule21},+	{7719, 1, &rule22},+	{7720, 1, &rule21},+	{7721, 1, &rule22},+	{7722, 1, &rule21},+	{7723, 1, &rule22},+	{7724, 1, &rule21},+	{7725, 1, &rule22},+	{7726, 1, &rule21},+	{7727, 1, &rule22},+	{7728, 1, &rule21},+	{7729, 1, &rule22},+	{7730, 1, &rule21},+	{7731, 1, &rule22},+	{7732, 1, &rule21},+	{7733, 1, &rule22},+	{7734, 1, &rule21},+	{7735, 1, &rule22},+	{7736, 1, &rule21},+	{7737, 1, &rule22},+	{7738, 1, &rule21},+	{7739, 1, &rule22},+	{7740, 1, &rule21},+	{7741, 1, &rule22},+	{7742, 1, &rule21},+	{7743, 1, &rule22},+	{7744, 1, &rule21},+	{7745, 1, &rule22},+	{7746, 1, &rule21},+	{7747, 1, &rule22},+	{7748, 1, &rule21},+	{7749, 1, &rule22},+	{7750, 1, &rule21},+	{7751, 1, &rule22},+	{7752, 1, &rule21},+	{7753, 1, &rule22},+	{7754, 1, &rule21},+	{7755, 1, &rule22},+	{7756, 1, &rule21},+	{7757, 1, &rule22},+	{7758, 1, &rule21},+	{7759, 1, &rule22},+	{7760, 1, &rule21},+	{7761, 1, &rule22},+	{7762, 1, &rule21},+	{7763, 1, &rule22},+	{7764, 1, &rule21},+	{7765, 1, &rule22},+	{7766, 1, &rule21},+	{7767, 1, &rule22},+	{7768, 1, &rule21},+	{7769, 1, &rule22},+	{7770, 1, &rule21},+	{7771, 1, &rule22},+	{7772, 1, &rule21},+	{7773, 1, &rule22},+	{7774, 1, &rule21},+	{7775, 1, &rule22},+	{7776, 1, &rule21},+	{7777, 1, &rule22},+	{7778, 1, &rule21},+	{7779, 1, &rule22},+	{7780, 1, &rule21},+	{7781, 1, &rule22},+	{7782, 1, &rule21},+	{7783, 1, &rule22},+	{7784, 1, &rule21},+	{7785, 1, &rule22},+	{7786, 1, &rule21},+	{7787, 1, &rule22},+	{7788, 1, &rule21},+	{7789, 1, &rule22},+	{7790, 1, &rule21},+	{7791, 1, &rule22},+	{7792, 1, &rule21},+	{7793, 1, &rule22},+	{7794, 1, &rule21},+	{7795, 1, &rule22},+	{7796, 1, &rule21},+	{7797, 1, &rule22},+	{7798, 1, &rule21},+	{7799, 1, &rule22},+	{7800, 1, &rule21},+	{7801, 1, &rule22},+	{7802, 1, &rule21},+	{7803, 1, &rule22},+	{7804, 1, &rule21},+	{7805, 1, &rule22},+	{7806, 1, &rule21},+	{7807, 1, &rule22},+	{7808, 1, &rule21},+	{7809, 1, &rule22},+	{7810, 1, &rule21},+	{7811, 1, &rule22},+	{7812, 1, &rule21},+	{7813, 1, &rule22},+	{7814, 1, &rule21},+	{7815, 1, &rule22},+	{7816, 1, &rule21},+	{7817, 1, &rule22},+	{7818, 1, &rule21},+	{7819, 1, &rule22},+	{7820, 1, &rule21},+	{7821, 1, &rule22},+	{7822, 1, &rule21},+	{7823, 1, &rule22},+	{7824, 1, &rule21},+	{7825, 1, &rule22},+	{7826, 1, &rule21},+	{7827, 1, &rule22},+	{7828, 1, &rule21},+	{7829, 1, &rule22},+	{7830, 5, &rule14},+	{7835, 1, &rule116},+	{7836, 2, &rule14},+	{7838, 1, &rule117},+	{7839, 1, &rule14},+	{7840, 1, &rule21},+	{7841, 1, &rule22},+	{7842, 1, &rule21},+	{7843, 1, &rule22},+	{7844, 1, &rule21},+	{7845, 1, &rule22},+	{7846, 1, &rule21},+	{7847, 1, &rule22},+	{7848, 1, &rule21},+	{7849, 1, &rule22},+	{7850, 1, &rule21},+	{7851, 1, &rule22},+	{7852, 1, &rule21},+	{7853, 1, &rule22},+	{7854, 1, &rule21},+	{7855, 1, &rule22},+	{7856, 1, &rule21},+	{7857, 1, &rule22},+	{7858, 1, &rule21},+	{7859, 1, &rule22},+	{7860, 1, &rule21},+	{7861, 1, &rule22},+	{7862, 1, &rule21},+	{7863, 1, &rule22},+	{7864, 1, &rule21},+	{7865, 1, &rule22},+	{7866, 1, &rule21},+	{7867, 1, &rule22},+	{7868, 1, &rule21},+	{7869, 1, &rule22},+	{7870, 1, &rule21},+	{7871, 1, &rule22},+	{7872, 1, &rule21},+	{7873, 1, &rule22},+	{7874, 1, &rule21},+	{7875, 1, &rule22},+	{7876, 1, &rule21},+	{7877, 1, &rule22},+	{7878, 1, &rule21},+	{7879, 1, &rule22},+	{7880, 1, &rule21},+	{7881, 1, &rule22},+	{7882, 1, &rule21},+	{7883, 1, &rule22},+	{7884, 1, &rule21},+	{7885, 1, &rule22},+	{7886, 1, &rule21},+	{7887, 1, &rule22},+	{7888, 1, &rule21},+	{7889, 1, &rule22},+	{7890, 1, &rule21},+	{7891, 1, &rule22},+	{7892, 1, &rule21},+	{7893, 1, &rule22},+	{7894, 1, &rule21},+	{7895, 1, &rule22},+	{7896, 1, &rule21},+	{7897, 1, &rule22},+	{7898, 1, &rule21},+	{7899, 1, &rule22},+	{7900, 1, &rule21},+	{7901, 1, &rule22},+	{7902, 1, &rule21},+	{7903, 1, &rule22},+	{7904, 1, &rule21},+	{7905, 1, &rule22},+	{7906, 1, &rule21},+	{7907, 1, &rule22},+	{7908, 1, &rule21},+	{7909, 1, &rule22},+	{7910, 1, &rule21},+	{7911, 1, &rule22},+	{7912, 1, &rule21},+	{7913, 1, &rule22},+	{7914, 1, &rule21},+	{7915, 1, &rule22},+	{7916, 1, &rule21},+	{7917, 1, &rule22},+	{7918, 1, &rule21},+	{7919, 1, &rule22},+	{7920, 1, &rule21},+	{7921, 1, &rule22},+	{7922, 1, &rule21},+	{7923, 1, &rule22},+	{7924, 1, &rule21},+	{7925, 1, &rule22},+	{7926, 1, &rule21},+	{7927, 1, &rule22},+	{7928, 1, &rule21},+	{7929, 1, &rule22},+	{7930, 1, &rule21},+	{7931, 1, &rule22},+	{7932, 1, &rule21},+	{7933, 1, &rule22},+	{7934, 1, &rule21},+	{7935, 1, &rule22},+	{7936, 8, &rule118},+	{7944, 8, &rule119},+	{7952, 6, &rule118},+	{7960, 6, &rule119},+	{7968, 8, &rule118},+	{7976, 8, &rule119},+	{7984, 8, &rule118},+	{7992, 8, &rule119},+	{8000, 6, &rule118},+	{8008, 6, &rule119},+	{8016, 1, &rule14},+	{8017, 1, &rule118},+	{8018, 1, &rule14},+	{8019, 1, &rule118},+	{8020, 1, &rule14},+	{8021, 1, &rule118},+	{8022, 1, &rule14},+	{8023, 1, &rule118},+	{8025, 1, &rule119},+	{8027, 1, &rule119},+	{8029, 1, &rule119},+	{8031, 1, &rule119},+	{8032, 8, &rule118},+	{8040, 8, &rule119},+	{8048, 2, &rule120},+	{8050, 4, &rule121},+	{8054, 2, &rule122},+	{8056, 2, &rule123},+	{8058, 2, &rule124},+	{8060, 2, &rule125},+	{8064, 8, &rule118},+	{8072, 8, &rule126},+	{8080, 8, &rule118},+	{8088, 8, &rule126},+	{8096, 8, &rule118},+	{8104, 8, &rule126},+	{8112, 2, &rule118},+	{8114, 1, &rule14},+	{8115, 1, &rule127},+	{8116, 1, &rule14},+	{8118, 2, &rule14},+	{8120, 2, &rule119},+	{8122, 2, &rule128},+	{8124, 1, &rule129},+	{8125, 1, &rule10},+	{8126, 1, &rule130},+	{8127, 3, &rule10},+	{8130, 1, &rule14},+	{8131, 1, &rule127},+	{8132, 1, &rule14},+	{8134, 2, &rule14},+	{8136, 4, &rule131},+	{8140, 1, &rule129},+	{8141, 3, &rule10},+	{8144, 2, &rule118},+	{8146, 2, &rule14},+	{8150, 2, &rule14},+	{8152, 2, &rule119},+	{8154, 2, &rule132},+	{8157, 3, &rule10},+	{8160, 2, &rule118},+	{8162, 3, &rule14},+	{8165, 1, &rule101},+	{8166, 2, &rule14},+	{8168, 2, &rule119},+	{8170, 2, &rule133},+	{8172, 1, &rule104},+	{8173, 3, &rule10},+	{8178, 1, &rule14},+	{8179, 1, &rule127},+	{8180, 1, &rule14},+	{8182, 2, &rule14},+	{8184, 2, &rule134},+	{8186, 2, &rule135},+	{8188, 1, &rule129},+	{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, &rule136},+	{8233, 1, &rule137},+	{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},+	{8298, 6, &rule16},+	{8304, 1, &rule17},+	{8305, 1, &rule14},+	{8308, 6, &rule17},+	{8314, 3, &rule6},+	{8317, 1, &rule4},+	{8318, 1, &rule5},+	{8319, 1, &rule14},+	{8320, 10, &rule17},+	{8330, 3, &rule6},+	{8333, 1, &rule4},+	{8334, 1, &rule5},+	{8336, 5, &rule80},+	{8352, 22, &rule3},+	{8400, 13, &rule81},+	{8413, 4, &rule106},+	{8417, 1, &rule81},+	{8418, 3, &rule106},+	{8421, 12, &rule81},+	{8448, 2, &rule13},+	{8450, 1, &rule95},+	{8451, 4, &rule13},+	{8455, 1, &rule95},+	{8456, 2, &rule13},+	{8458, 1, &rule14},+	{8459, 3, &rule95},+	{8462, 2, &rule14},+	{8464, 3, &rule95},+	{8467, 1, &rule14},+	{8468, 1, &rule13},+	{8469, 1, &rule95},+	{8470, 3, &rule13},+	{8473, 5, &rule95},+	{8478, 6, &rule13},+	{8484, 1, &rule95},+	{8485, 1, &rule13},+	{8486, 1, &rule138},+	{8487, 1, &rule13},+	{8488, 1, &rule95},+	{8489, 1, &rule13},+	{8490, 1, &rule139},+	{8491, 1, &rule140},+	{8492, 2, &rule95},+	{8494, 1, &rule13},+	{8495, 1, &rule14},+	{8496, 2, &rule95},+	{8498, 1, &rule141},+	{8499, 1, &rule95},+	{8500, 1, &rule14},+	{8501, 4, &rule45},+	{8505, 1, &rule14},+	{8506, 2, &rule13},+	{8508, 2, &rule14},+	{8510, 2, &rule95},+	{8512, 5, &rule6},+	{8517, 1, &rule95},+	{8518, 4, &rule14},+	{8522, 1, &rule13},+	{8523, 1, &rule6},+	{8524, 2, &rule13},+	{8526, 1, &rule142},+	{8527, 1, &rule13},+	{8531, 13, &rule17},+	{8544, 16, &rule143},+	{8560, 16, &rule144},+	{8576, 3, &rule113},+	{8579, 1, &rule21},+	{8580, 1, &rule22},+	{8581, 4, &rule113},+	{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, 4, &rule6},+	{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, 6, &rule13},+	{9216, 39, &rule13},+	{9280, 11, &rule13},+	{9312, 60, &rule17},+	{9372, 26, &rule13},+	{9398, 26, &rule145},+	{9424, 26, &rule146},+	{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, 46, &rule13},+	{9888, 29, &rule13},+	{9920, 4, &rule13},+	{9985, 4, &rule13},+	{9990, 4, &rule13},+	{9996, 28, &rule13},+	{10025, 35, &rule13},+	{10061, 1, &rule13},+	{10063, 4, &rule13},+	{10070, 1, &rule13},+	{10072, 7, &rule13},+	{10081, 7, &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, 1, &rule13},+	{10136, 24, &rule13},+	{10161, 14, &rule13},+	{10176, 5, &rule6},+	{10181, 1, &rule4},+	{10182, 1, &rule5},+	{10183, 4, &rule6},+	{10188, 1, &rule6},+	{10192, 22, &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},+	{11088, 5, &rule13},+	{11264, 47, &rule109},+	{11312, 47, &rule110},+	{11360, 1, &rule21},+	{11361, 1, &rule22},+	{11362, 1, &rule147},+	{11363, 1, &rule148},+	{11364, 1, &rule149},+	{11365, 1, &rule150},+	{11366, 1, &rule151},+	{11367, 1, &rule21},+	{11368, 1, &rule22},+	{11369, 1, &rule21},+	{11370, 1, &rule22},+	{11371, 1, &rule21},+	{11372, 1, &rule22},+	{11373, 1, &rule152},+	{11374, 1, &rule153},+	{11375, 1, &rule154},+	{11377, 1, &rule14},+	{11378, 1, &rule21},+	{11379, 1, &rule22},+	{11380, 1, &rule14},+	{11381, 1, &rule21},+	{11382, 1, &rule22},+	{11383, 6, &rule14},+	{11389, 1, &rule80},+	{11392, 1, &rule21},+	{11393, 1, &rule22},+	{11394, 1, &rule21},+	{11395, 1, &rule22},+	{11396, 1, &rule21},+	{11397, 1, &rule22},+	{11398, 1, &rule21},+	{11399, 1, &rule22},+	{11400, 1, &rule21},+	{11401, 1, &rule22},+	{11402, 1, &rule21},+	{11403, 1, &rule22},+	{11404, 1, &rule21},+	{11405, 1, &rule22},+	{11406, 1, &rule21},+	{11407, 1, &rule22},+	{11408, 1, &rule21},+	{11409, 1, &rule22},+	{11410, 1, &rule21},+	{11411, 1, &rule22},+	{11412, 1, &rule21},+	{11413, 1, &rule22},+	{11414, 1, &rule21},+	{11415, 1, &rule22},+	{11416, 1, &rule21},+	{11417, 1, &rule22},+	{11418, 1, &rule21},+	{11419, 1, &rule22},+	{11420, 1, &rule21},+	{11421, 1, &rule22},+	{11422, 1, &rule21},+	{11423, 1, &rule22},+	{11424, 1, &rule21},+	{11425, 1, &rule22},+	{11426, 1, &rule21},+	{11427, 1, &rule22},+	{11428, 1, &rule21},+	{11429, 1, &rule22},+	{11430, 1, &rule21},+	{11431, 1, &rule22},+	{11432, 1, &rule21},+	{11433, 1, &rule22},+	{11434, 1, &rule21},+	{11435, 1, &rule22},+	{11436, 1, &rule21},+	{11437, 1, &rule22},+	{11438, 1, &rule21},+	{11439, 1, &rule22},+	{11440, 1, &rule21},+	{11441, 1, &rule22},+	{11442, 1, &rule21},+	{11443, 1, &rule22},+	{11444, 1, &rule21},+	{11445, 1, &rule22},+	{11446, 1, &rule21},+	{11447, 1, &rule22},+	{11448, 1, &rule21},+	{11449, 1, &rule22},+	{11450, 1, &rule21},+	{11451, 1, &rule22},+	{11452, 1, &rule21},+	{11453, 1, &rule22},+	{11454, 1, &rule21},+	{11455, 1, &rule22},+	{11456, 1, &rule21},+	{11457, 1, &rule22},+	{11458, 1, &rule21},+	{11459, 1, &rule22},+	{11460, 1, &rule21},+	{11461, 1, &rule22},+	{11462, 1, &rule21},+	{11463, 1, &rule22},+	{11464, 1, &rule21},+	{11465, 1, &rule22},+	{11466, 1, &rule21},+	{11467, 1, &rule22},+	{11468, 1, &rule21},+	{11469, 1, &rule22},+	{11470, 1, &rule21},+	{11471, 1, &rule22},+	{11472, 1, &rule21},+	{11473, 1, &rule22},+	{11474, 1, &rule21},+	{11475, 1, &rule22},+	{11476, 1, &rule21},+	{11477, 1, &rule22},+	{11478, 1, &rule21},+	{11479, 1, &rule22},+	{11480, 1, &rule21},+	{11481, 1, &rule22},+	{11482, 1, &rule21},+	{11483, 1, &rule22},+	{11484, 1, &rule21},+	{11485, 1, &rule22},+	{11486, 1, &rule21},+	{11487, 1, &rule22},+	{11488, 1, &rule21},+	{11489, 1, &rule22},+	{11490, 1, &rule21},+	{11491, 1, &rule22},+	{11492, 1, &rule14},+	{11493, 6, &rule13},+	{11513, 4, &rule2},+	{11517, 1, &rule17},+	{11518, 2, &rule2},+	{11520, 38, &rule155},+	{11568, 54, &rule45},+	{11631, 1, &rule80},+	{11648, 23, &rule45},+	{11680, 7, &rule45},+	{11688, 7, &rule45},+	{11696, 7, &rule45},+	{11704, 7, &rule45},+	{11712, 7, &rule45},+	{11720, 7, &rule45},+	{11728, 7, &rule45},+	{11736, 7, &rule45},+	{11744, 32, &rule81},+	{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, &rule80},+	{11824, 1, &rule2},+	{11904, 26, &rule13},+	{11931, 89, &rule13},+	{12032, 214, &rule13},+	{12272, 12, &rule13},+	{12288, 1, &rule1},+	{12289, 3, &rule2},+	{12292, 1, &rule13},+	{12293, 1, &rule80},+	{12294, 1, &rule45},+	{12295, 1, &rule113},+	{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, &rule113},+	{12330, 6, &rule81},+	{12336, 1, &rule7},+	{12337, 5, &rule80},+	{12342, 2, &rule13},+	{12344, 3, &rule113},+	{12347, 1, &rule80},+	{12348, 1, &rule45},+	{12349, 1, &rule2},+	{12350, 2, &rule13},+	{12353, 86, &rule45},+	{12441, 2, &rule81},+	{12443, 2, &rule10},+	{12445, 2, &rule80},+	{12447, 1, &rule45},+	{12448, 1, &rule7},+	{12449, 90, &rule45},+	{12539, 1, &rule2},+	{12540, 3, &rule80},+	{12543, 1, &rule45},+	{12549, 41, &rule45},+	{12593, 94, &rule45},+	{12688, 2, &rule13},+	{12690, 4, &rule17},+	{12694, 10, &rule13},+	{12704, 24, &rule45},+	{12736, 36, &rule13},+	{12784, 16, &rule45},+	{12800, 31, &rule13},+	{12832, 10, &rule17},+	{12842, 26, &rule13},+	{12880, 1, &rule13},+	{12881, 15, &rule17},+	{12896, 32, &rule13},+	{12928, 10, &rule17},+	{12938, 39, &rule13},+	{12977, 15, &rule17},+	{12992, 63, &rule13},+	{13056, 256, &rule13},+	{13312, 6582, &rule45},+	{19904, 64, &rule13},+	{19968, 20932, &rule45},+	{40960, 21, &rule45},+	{40981, 1, &rule80},+	{40982, 1143, &rule45},+	{42128, 55, &rule13},+	{42240, 268, &rule45},+	{42508, 1, &rule80},+	{42509, 3, &rule2},+	{42512, 16, &rule45},+	{42528, 10, &rule8},+	{42538, 2, &rule45},+	{42560, 1, &rule21},+	{42561, 1, &rule22},+	{42562, 1, &rule21},+	{42563, 1, &rule22},+	{42564, 1, &rule21},+	{42565, 1, &rule22},+	{42566, 1, &rule21},+	{42567, 1, &rule22},+	{42568, 1, &rule21},+	{42569, 1, &rule22},+	{42570, 1, &rule21},+	{42571, 1, &rule22},+	{42572, 1, &rule21},+	{42573, 1, &rule22},+	{42574, 1, &rule21},+	{42575, 1, &rule22},+	{42576, 1, &rule21},+	{42577, 1, &rule22},+	{42578, 1, &rule21},+	{42579, 1, &rule22},+	{42580, 1, &rule21},+	{42581, 1, &rule22},+	{42582, 1, &rule21},+	{42583, 1, &rule22},+	{42584, 1, &rule21},+	{42585, 1, &rule22},+	{42586, 1, &rule21},+	{42587, 1, &rule22},+	{42588, 1, &rule21},+	{42589, 1, &rule22},+	{42590, 1, &rule21},+	{42591, 1, &rule22},+	{42594, 1, &rule21},+	{42595, 1, &rule22},+	{42596, 1, &rule21},+	{42597, 1, &rule22},+	{42598, 1, &rule21},+	{42599, 1, &rule22},+	{42600, 1, &rule21},+	{42601, 1, &rule22},+	{42602, 1, &rule21},+	{42603, 1, &rule22},+	{42604, 1, &rule21},+	{42605, 1, &rule22},+	{42606, 1, &rule45},+	{42607, 1, &rule81},+	{42608, 3, &rule106},+	{42611, 1, &rule2},+	{42620, 2, &rule81},+	{42622, 1, &rule2},+	{42623, 1, &rule80},+	{42624, 1, &rule21},+	{42625, 1, &rule22},+	{42626, 1, &rule21},+	{42627, 1, &rule22},+	{42628, 1, &rule21},+	{42629, 1, &rule22},+	{42630, 1, &rule21},+	{42631, 1, &rule22},+	{42632, 1, &rule21},+	{42633, 1, &rule22},+	{42634, 1, &rule21},+	{42635, 1, &rule22},+	{42636, 1, &rule21},+	{42637, 1, &rule22},+	{42638, 1, &rule21},+	{42639, 1, &rule22},+	{42640, 1, &rule21},+	{42641, 1, &rule22},+	{42642, 1, &rule21},+	{42643, 1, &rule22},+	{42644, 1, &rule21},+	{42645, 1, &rule22},+	{42646, 1, &rule21},+	{42647, 1, &rule22},+	{42752, 23, &rule10},+	{42775, 9, &rule80},+	{42784, 2, &rule10},+	{42786, 1, &rule21},+	{42787, 1, &rule22},+	{42788, 1, &rule21},+	{42789, 1, &rule22},+	{42790, 1, &rule21},+	{42791, 1, &rule22},+	{42792, 1, &rule21},+	{42793, 1, &rule22},+	{42794, 1, &rule21},+	{42795, 1, &rule22},+	{42796, 1, &rule21},+	{42797, 1, &rule22},+	{42798, 1, &rule21},+	{42799, 1, &rule22},+	{42800, 2, &rule14},+	{42802, 1, &rule21},+	{42803, 1, &rule22},+	{42804, 1, &rule21},+	{42805, 1, &rule22},+	{42806, 1, &rule21},+	{42807, 1, &rule22},+	{42808, 1, &rule21},+	{42809, 1, &rule22},+	{42810, 1, &rule21},+	{42811, 1, &rule22},+	{42812, 1, &rule21},+	{42813, 1, &rule22},+	{42814, 1, &rule21},+	{42815, 1, &rule22},+	{42816, 1, &rule21},+	{42817, 1, &rule22},+	{42818, 1, &rule21},+	{42819, 1, &rule22},+	{42820, 1, &rule21},+	{42821, 1, &rule22},+	{42822, 1, &rule21},+	{42823, 1, &rule22},+	{42824, 1, &rule21},+	{42825, 1, &rule22},+	{42826, 1, &rule21},+	{42827, 1, &rule22},+	{42828, 1, &rule21},+	{42829, 1, &rule22},+	{42830, 1, &rule21},+	{42831, 1, &rule22},+	{42832, 1, &rule21},+	{42833, 1, &rule22},+	{42834, 1, &rule21},+	{42835, 1, &rule22},+	{42836, 1, &rule21},+	{42837, 1, &rule22},+	{42838, 1, &rule21},+	{42839, 1, &rule22},+	{42840, 1, &rule21},+	{42841, 1, &rule22},+	{42842, 1, &rule21},+	{42843, 1, &rule22},+	{42844, 1, &rule21},+	{42845, 1, &rule22},+	{42846, 1, &rule21},+	{42847, 1, &rule22},+	{42848, 1, &rule21},+	{42849, 1, &rule22},+	{42850, 1, &rule21},+	{42851, 1, &rule22},+	{42852, 1, &rule21},+	{42853, 1, &rule22},+	{42854, 1, &rule21},+	{42855, 1, &rule22},+	{42856, 1, &rule21},+	{42857, 1, &rule22},+	{42858, 1, &rule21},+	{42859, 1, &rule22},+	{42860, 1, &rule21},+	{42861, 1, &rule22},+	{42862, 1, &rule21},+	{42863, 1, &rule22},+	{42864, 1, &rule80},+	{42865, 8, &rule14},+	{42873, 1, &rule21},+	{42874, 1, &rule22},+	{42875, 1, &rule21},+	{42876, 1, &rule22},+	{42877, 1, &rule156},+	{42878, 1, &rule21},+	{42879, 1, &rule22},+	{42880, 1, &rule21},+	{42881, 1, &rule22},+	{42882, 1, &rule21},+	{42883, 1, &rule22},+	{42884, 1, &rule21},+	{42885, 1, &rule22},+	{42886, 1, &rule21},+	{42887, 1, &rule22},+	{42888, 1, &rule80},+	{42889, 2, &rule10},+	{42891, 1, &rule21},+	{42892, 1, &rule22},+	{43003, 7, &rule45},+	{43010, 1, &rule81},+	{43011, 3, &rule45},+	{43014, 1, &rule81},+	{43015, 4, &rule45},+	{43019, 1, &rule81},+	{43020, 23, &rule45},+	{43043, 2, &rule111},+	{43045, 2, &rule81},+	{43047, 1, &rule111},+	{43048, 4, &rule13},+	{43072, 52, &rule45},+	{43124, 4, &rule2},+	{43136, 2, &rule111},+	{43138, 50, &rule45},+	{43188, 16, &rule111},+	{43204, 1, &rule81},+	{43214, 2, &rule2},+	{43216, 10, &rule8},+	{43264, 10, &rule8},+	{43274, 28, &rule45},+	{43302, 8, &rule81},+	{43310, 2, &rule2},+	{43312, 23, &rule45},+	{43335, 11, &rule81},+	{43346, 2, &rule111},+	{43359, 1, &rule2},+	{43520, 41, &rule45},+	{43561, 6, &rule81},+	{43567, 2, &rule111},+	{43569, 2, &rule81},+	{43571, 2, &rule111},+	{43573, 2, &rule81},+	{43584, 3, &rule45},+	{43587, 1, &rule81},+	{43588, 8, &rule45},+	{43596, 1, &rule81},+	{43597, 1, &rule111},+	{43600, 10, &rule8},+	{43612, 4, &rule2},+	{44032, 11172, &rule45},+	{55296, 896, &rule157},+	{56192, 128, &rule157},+	{56320, 1024, &rule157},+	{57344, 6400, &rule158},+	{63744, 302, &rule45},+	{64048, 59, &rule45},+	{64112, 106, &rule45},+	{64256, 7, &rule14},+	{64275, 5, &rule14},+	{64285, 1, &rule45},+	{64286, 1, &rule81},+	{64287, 10, &rule45},+	{64297, 1, &rule6},+	{64298, 13, &rule45},+	{64312, 5, &rule45},+	{64318, 1, &rule45},+	{64320, 2, &rule45},+	{64323, 2, &rule45},+	{64326, 108, &rule45},+	{64467, 363, &rule45},+	{64830, 1, &rule4},+	{64831, 1, &rule5},+	{64848, 64, &rule45},+	{64914, 54, &rule45},+	{65008, 12, &rule45},+	{65020, 1, &rule3},+	{65021, 1, &rule13},+	{65024, 16, &rule81},+	{65040, 7, &rule2},+	{65047, 1, &rule4},+	{65048, 1, &rule5},+	{65049, 1, &rule2},+	{65056, 7, &rule81},+	{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, &rule45},+	{65142, 135, &rule45},+	{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, &rule45},+	{65392, 1, &rule80},+	{65393, 45, &rule45},+	{65438, 2, &rule80},+	{65440, 31, &rule45},+	{65474, 6, &rule45},+	{65482, 6, &rule45},+	{65490, 6, &rule45},+	{65498, 3, &rule45},+	{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, &rule45},+	{65549, 26, &rule45},+	{65576, 19, &rule45},+	{65596, 2, &rule45},+	{65599, 15, &rule45},+	{65616, 14, &rule45},+	{65664, 123, &rule45},+	{65792, 2, &rule2},+	{65794, 1, &rule13},+	{65799, 45, &rule17},+	{65847, 9, &rule13},+	{65856, 53, &rule113},+	{65909, 4, &rule17},+	{65913, 17, &rule13},+	{65930, 1, &rule17},+	{65936, 12, &rule13},+	{66000, 45, &rule13},+	{66045, 1, &rule81},+	{66176, 29, &rule45},+	{66208, 49, &rule45},+	{66304, 31, &rule45},+	{66336, 4, &rule17},+	{66352, 17, &rule45},+	{66369, 1, &rule113},+	{66370, 8, &rule45},+	{66378, 1, &rule113},+	{66432, 30, &rule45},+	{66463, 1, &rule2},+	{66464, 36, &rule45},+	{66504, 8, &rule45},+	{66512, 1, &rule2},+	{66513, 5, &rule113},+	{66560, 40, &rule159},+	{66600, 40, &rule160},+	{66640, 78, &rule45},+	{66720, 10, &rule8},+	{67584, 6, &rule45},+	{67592, 1, &rule45},+	{67594, 44, &rule45},+	{67639, 2, &rule45},+	{67644, 1, &rule45},+	{67647, 1, &rule45},+	{67840, 22, &rule45},+	{67862, 4, &rule17},+	{67871, 1, &rule2},+	{67872, 26, &rule45},+	{67903, 1, &rule2},+	{68096, 1, &rule45},+	{68097, 3, &rule81},+	{68101, 2, &rule81},+	{68108, 4, &rule81},+	{68112, 4, &rule45},+	{68117, 3, &rule45},+	{68121, 27, &rule45},+	{68152, 3, &rule81},+	{68159, 1, &rule81},+	{68160, 8, &rule17},+	{68176, 9, &rule2},+	{73728, 879, &rule45},+	{74752, 99, &rule113},+	{74864, 4, &rule2},+	{118784, 246, &rule13},+	{119040, 39, &rule13},+	{119081, 60, &rule13},+	{119141, 2, &rule111},+	{119143, 3, &rule81},+	{119146, 3, &rule13},+	{119149, 6, &rule111},+	{119155, 8, &rule16},+	{119163, 8, &rule81},+	{119171, 2, &rule13},+	{119173, 7, &rule81},+	{119180, 30, &rule13},+	{119210, 4, &rule81},+	{119214, 48, &rule13},+	{119296, 66, &rule13},+	{119362, 3, &rule81},+	{119365, 1, &rule13},+	{119552, 87, &rule13},+	{119648, 18, &rule17},+	{119808, 26, &rule95},+	{119834, 26, &rule14},+	{119860, 26, &rule95},+	{119886, 7, &rule14},+	{119894, 18, &rule14},+	{119912, 26, &rule95},+	{119938, 26, &rule14},+	{119964, 1, &rule95},+	{119966, 2, &rule95},+	{119970, 1, &rule95},+	{119973, 2, &rule95},+	{119977, 4, &rule95},+	{119982, 8, &rule95},+	{119990, 4, &rule14},+	{119995, 1, &rule14},+	{119997, 7, &rule14},+	{120005, 11, &rule14},+	{120016, 26, &rule95},+	{120042, 26, &rule14},+	{120068, 2, &rule95},+	{120071, 4, &rule95},+	{120077, 8, &rule95},+	{120086, 7, &rule95},+	{120094, 26, &rule14},+	{120120, 2, &rule95},+	{120123, 4, &rule95},+	{120128, 5, &rule95},+	{120134, 1, &rule95},+	{120138, 7, &rule95},+	{120146, 26, &rule14},+	{120172, 26, &rule95},+	{120198, 26, &rule14},+	{120224, 26, &rule95},+	{120250, 26, &rule14},+	{120276, 26, &rule95},+	{120302, 26, &rule14},+	{120328, 26, &rule95},+	{120354, 26, &rule14},+	{120380, 26, &rule95},+	{120406, 26, &rule14},+	{120432, 26, &rule95},+	{120458, 28, &rule14},+	{120488, 25, &rule95},+	{120513, 1, &rule6},+	{120514, 25, &rule14},+	{120539, 1, &rule6},+	{120540, 6, &rule14},+	{120546, 25, &rule95},+	{120571, 1, &rule6},+	{120572, 25, &rule14},+	{120597, 1, &rule6},+	{120598, 6, &rule14},+	{120604, 25, &rule95},+	{120629, 1, &rule6},+	{120630, 25, &rule14},+	{120655, 1, &rule6},+	{120656, 6, &rule14},+	{120662, 25, &rule95},+	{120687, 1, &rule6},+	{120688, 25, &rule14},+	{120713, 1, &rule6},+	{120714, 6, &rule14},+	{120720, 25, &rule95},+	{120745, 1, &rule6},+	{120746, 25, &rule14},+	{120771, 1, &rule6},+	{120772, 6, &rule14},+	{120778, 1, &rule95},+	{120779, 1, &rule14},+	{120782, 50, &rule8},+	{126976, 44, &rule13},+	{127024, 100, &rule13},+	{131072, 42711, &rule45},+	{194560, 542, &rule45},+	{917505, 1, &rule16},+	{917536, 96, &rule16},+	{917760, 240, &rule81},+	{983040, 65534, &rule158},+	{1048576, 65534, &rule158}+};+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, &rule20},+	{256, 1, &rule21},+	{257, 1, &rule22},+	{258, 1, &rule21},+	{259, 1, &rule22},+	{260, 1, &rule21},+	{261, 1, &rule22},+	{262, 1, &rule21},+	{263, 1, &rule22},+	{264, 1, &rule21},+	{265, 1, &rule22},+	{266, 1, &rule21},+	{267, 1, &rule22},+	{268, 1, &rule21},+	{269, 1, &rule22},+	{270, 1, &rule21},+	{271, 1, &rule22},+	{272, 1, &rule21},+	{273, 1, &rule22},+	{274, 1, &rule21},+	{275, 1, &rule22},+	{276, 1, &rule21},+	{277, 1, &rule22},+	{278, 1, &rule21},+	{279, 1, &rule22},+	{280, 1, &rule21},+	{281, 1, &rule22},+	{282, 1, &rule21},+	{283, 1, &rule22},+	{284, 1, &rule21},+	{285, 1, &rule22},+	{286, 1, &rule21},+	{287, 1, &rule22},+	{288, 1, &rule21},+	{289, 1, &rule22},+	{290, 1, &rule21},+	{291, 1, &rule22},+	{292, 1, &rule21},+	{293, 1, &rule22},+	{294, 1, &rule21},+	{295, 1, &rule22},+	{296, 1, &rule21},+	{297, 1, &rule22},+	{298, 1, &rule21},+	{299, 1, &rule22},+	{300, 1, &rule21},+	{301, 1, &rule22},+	{302, 1, &rule21},+	{303, 1, &rule22},+	{304, 1, &rule23},+	{305, 1, &rule24},+	{306, 1, &rule21},+	{307, 1, &rule22},+	{308, 1, &rule21},+	{309, 1, &rule22},+	{310, 1, &rule21},+	{311, 1, &rule22},+	{313, 1, &rule21},+	{314, 1, &rule22},+	{315, 1, &rule21},+	{316, 1, &rule22},+	{317, 1, &rule21},+	{318, 1, &rule22},+	{319, 1, &rule21},+	{320, 1, &rule22},+	{321, 1, &rule21},+	{322, 1, &rule22},+	{323, 1, &rule21},+	{324, 1, &rule22},+	{325, 1, &rule21},+	{326, 1, &rule22},+	{327, 1, &rule21},+	{328, 1, &rule22},+	{330, 1, &rule21},+	{331, 1, &rule22},+	{332, 1, &rule21},+	{333, 1, &rule22},+	{334, 1, &rule21},+	{335, 1, &rule22},+	{336, 1, &rule21},+	{337, 1, &rule22},+	{338, 1, &rule21},+	{339, 1, &rule22},+	{340, 1, &rule21},+	{341, 1, &rule22},+	{342, 1, &rule21},+	{343, 1, &rule22},+	{344, 1, &rule21},+	{345, 1, &rule22},+	{346, 1, &rule21},+	{347, 1, &rule22},+	{348, 1, &rule21},+	{349, 1, &rule22},+	{350, 1, &rule21},+	{351, 1, &rule22},+	{352, 1, &rule21},+	{353, 1, &rule22},+	{354, 1, &rule21},+	{355, 1, &rule22},+	{356, 1, &rule21},+	{357, 1, &rule22},+	{358, 1, &rule21},+	{359, 1, &rule22},+	{360, 1, &rule21},+	{361, 1, &rule22},+	{362, 1, &rule21},+	{363, 1, &rule22},+	{364, 1, &rule21},+	{365, 1, &rule22},+	{366, 1, &rule21},+	{367, 1, &rule22},+	{368, 1, &rule21},+	{369, 1, &rule22},+	{370, 1, &rule21},+	{371, 1, &rule22},+	{372, 1, &rule21},+	{373, 1, &rule22},+	{374, 1, &rule21},+	{375, 1, &rule22},+	{376, 1, &rule25},+	{377, 1, &rule21},+	{378, 1, &rule22},+	{379, 1, &rule21},+	{380, 1, &rule22},+	{381, 1, &rule21},+	{382, 1, &rule22},+	{383, 1, &rule26},+	{384, 1, &rule27},+	{385, 1, &rule28},+	{386, 1, &rule21},+	{387, 1, &rule22},+	{388, 1, &rule21},+	{389, 1, &rule22},+	{390, 1, &rule29},+	{391, 1, &rule21},+	{392, 1, &rule22},+	{393, 2, &rule30},+	{395, 1, &rule21},+	{396, 1, &rule22},+	{398, 1, &rule31},+	{399, 1, &rule32},+	{400, 1, &rule33},+	{401, 1, &rule21},+	{402, 1, &rule22},+	{403, 1, &rule30},+	{404, 1, &rule34},+	{405, 1, &rule35},+	{406, 1, &rule36},+	{407, 1, &rule37},+	{408, 1, &rule21},+	{409, 1, &rule22},+	{410, 1, &rule38},+	{412, 1, &rule36},+	{413, 1, &rule39},+	{414, 1, &rule40},+	{415, 1, &rule41},+	{416, 1, &rule21},+	{417, 1, &rule22},+	{418, 1, &rule21},+	{419, 1, &rule22},+	{420, 1, &rule21},+	{421, 1, &rule22},+	{422, 1, &rule42},+	{423, 1, &rule21},+	{424, 1, &rule22},+	{425, 1, &rule42},+	{428, 1, &rule21},+	{429, 1, &rule22},+	{430, 1, &rule42},+	{431, 1, &rule21},+	{432, 1, &rule22},+	{433, 2, &rule43},+	{435, 1, &rule21},+	{436, 1, &rule22},+	{437, 1, &rule21},+	{438, 1, &rule22},+	{439, 1, &rule44},+	{440, 1, &rule21},+	{441, 1, &rule22},+	{444, 1, &rule21},+	{445, 1, &rule22},+	{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, &rule21},+	{462, 1, &rule22},+	{463, 1, &rule21},+	{464, 1, &rule22},+	{465, 1, &rule21},+	{466, 1, &rule22},+	{467, 1, &rule21},+	{468, 1, &rule22},+	{469, 1, &rule21},+	{470, 1, &rule22},+	{471, 1, &rule21},+	{472, 1, &rule22},+	{473, 1, &rule21},+	{474, 1, &rule22},+	{475, 1, &rule21},+	{476, 1, &rule22},+	{477, 1, &rule50},+	{478, 1, &rule21},+	{479, 1, &rule22},+	{480, 1, &rule21},+	{481, 1, &rule22},+	{482, 1, &rule21},+	{483, 1, &rule22},+	{484, 1, &rule21},+	{485, 1, &rule22},+	{486, 1, &rule21},+	{487, 1, &rule22},+	{488, 1, &rule21},+	{489, 1, &rule22},+	{490, 1, &rule21},+	{491, 1, &rule22},+	{492, 1, &rule21},+	{493, 1, &rule22},+	{494, 1, &rule21},+	{495, 1, &rule22},+	{497, 1, &rule47},+	{498, 1, &rule48},+	{499, 1, &rule49},+	{500, 1, &rule21},+	{501, 1, &rule22},+	{502, 1, &rule51},+	{503, 1, &rule52},+	{504, 1, &rule21},+	{505, 1, &rule22},+	{506, 1, &rule21},+	{507, 1, &rule22},+	{508, 1, &rule21},+	{509, 1, &rule22},+	{510, 1, &rule21},+	{511, 1, &rule22},+	{512, 1, &rule21},+	{513, 1, &rule22},+	{514, 1, &rule21},+	{515, 1, &rule22},+	{516, 1, &rule21},+	{517, 1, &rule22},+	{518, 1, &rule21},+	{519, 1, &rule22},+	{520, 1, &rule21},+	{521, 1, &rule22},+	{522, 1, &rule21},+	{523, 1, &rule22},+	{524, 1, &rule21},+	{525, 1, &rule22},+	{526, 1, &rule21},+	{527, 1, &rule22},+	{528, 1, &rule21},+	{529, 1, &rule22},+	{530, 1, &rule21},+	{531, 1, &rule22},+	{532, 1, &rule21},+	{533, 1, &rule22},+	{534, 1, &rule21},+	{535, 1, &rule22},+	{536, 1, &rule21},+	{537, 1, &rule22},+	{538, 1, &rule21},+	{539, 1, &rule22},+	{540, 1, &rule21},+	{541, 1, &rule22},+	{542, 1, &rule21},+	{543, 1, &rule22},+	{544, 1, &rule53},+	{546, 1, &rule21},+	{547, 1, &rule22},+	{548, 1, &rule21},+	{549, 1, &rule22},+	{550, 1, &rule21},+	{551, 1, &rule22},+	{552, 1, &rule21},+	{553, 1, &rule22},+	{554, 1, &rule21},+	{555, 1, &rule22},+	{556, 1, &rule21},+	{557, 1, &rule22},+	{558, 1, &rule21},+	{559, 1, &rule22},+	{560, 1, &rule21},+	{561, 1, &rule22},+	{562, 1, &rule21},+	{563, 1, &rule22},+	{570, 1, &rule54},+	{571, 1, &rule21},+	{572, 1, &rule22},+	{573, 1, &rule55},+	{574, 1, &rule56},+	{577, 1, &rule21},+	{578, 1, &rule22},+	{579, 1, &rule57},+	{580, 1, &rule58},+	{581, 1, &rule59},+	{582, 1, &rule21},+	{583, 1, &rule22},+	{584, 1, &rule21},+	{585, 1, &rule22},+	{586, 1, &rule21},+	{587, 1, &rule22},+	{588, 1, &rule21},+	{589, 1, &rule22},+	{590, 1, &rule21},+	{591, 1, &rule22},+	{592, 1, &rule60},+	{593, 1, &rule61},+	{595, 1, &rule62},+	{596, 1, &rule63},+	{598, 2, &rule64},+	{601, 1, &rule65},+	{603, 1, &rule66},+	{608, 1, &rule64},+	{611, 1, &rule67},+	{616, 1, &rule68},+	{617, 1, &rule69},+	{619, 1, &rule70},+	{623, 1, &rule69},+	{625, 1, &rule71},+	{626, 1, &rule72},+	{629, 1, &rule73},+	{637, 1, &rule74},+	{640, 1, &rule75},+	{643, 1, &rule75},+	{648, 1, &rule75},+	{649, 1, &rule76},+	{650, 2, &rule77},+	{652, 1, &rule78},+	{658, 1, &rule79},+	{837, 1, &rule82},+	{880, 1, &rule21},+	{881, 1, &rule22},+	{882, 1, &rule21},+	{883, 1, &rule22},+	{886, 1, &rule21},+	{887, 1, &rule22},+	{891, 3, &rule40},+	{902, 1, &rule83},+	{904, 3, &rule84},+	{908, 1, &rule85},+	{910, 2, &rule86},+	{913, 17, &rule9},+	{931, 9, &rule9},+	{940, 1, &rule87},+	{941, 3, &rule88},+	{945, 17, &rule12},+	{962, 1, &rule89},+	{963, 9, &rule12},+	{972, 1, &rule90},+	{973, 2, &rule91},+	{975, 1, &rule92},+	{976, 1, &rule93},+	{977, 1, &rule94},+	{981, 1, &rule96},+	{982, 1, &rule97},+	{983, 1, &rule98},+	{984, 1, &rule21},+	{985, 1, &rule22},+	{986, 1, &rule21},+	{987, 1, &rule22},+	{988, 1, &rule21},+	{989, 1, &rule22},+	{990, 1, &rule21},+	{991, 1, &rule22},+	{992, 1, &rule21},+	{993, 1, &rule22},+	{994, 1, &rule21},+	{995, 1, &rule22},+	{996, 1, &rule21},+	{997, 1, &rule22},+	{998, 1, &rule21},+	{999, 1, &rule22},+	{1000, 1, &rule21},+	{1001, 1, &rule22},+	{1002, 1, &rule21},+	{1003, 1, &rule22},+	{1004, 1, &rule21},+	{1005, 1, &rule22},+	{1006, 1, &rule21},+	{1007, 1, &rule22},+	{1008, 1, &rule99},+	{1009, 1, &rule100},+	{1010, 1, &rule101},+	{1012, 1, &rule102},+	{1013, 1, &rule103},+	{1015, 1, &rule21},+	{1016, 1, &rule22},+	{1017, 1, &rule104},+	{1018, 1, &rule21},+	{1019, 1, &rule22},+	{1021, 3, &rule53},+	{1024, 16, &rule105},+	{1040, 32, &rule9},+	{1072, 32, &rule12},+	{1104, 16, &rule100},+	{1120, 1, &rule21},+	{1121, 1, &rule22},+	{1122, 1, &rule21},+	{1123, 1, &rule22},+	{1124, 1, &rule21},+	{1125, 1, &rule22},+	{1126, 1, &rule21},+	{1127, 1, &rule22},+	{1128, 1, &rule21},+	{1129, 1, &rule22},+	{1130, 1, &rule21},+	{1131, 1, &rule22},+	{1132, 1, &rule21},+	{1133, 1, &rule22},+	{1134, 1, &rule21},+	{1135, 1, &rule22},+	{1136, 1, &rule21},+	{1137, 1, &rule22},+	{1138, 1, &rule21},+	{1139, 1, &rule22},+	{1140, 1, &rule21},+	{1141, 1, &rule22},+	{1142, 1, &rule21},+	{1143, 1, &rule22},+	{1144, 1, &rule21},+	{1145, 1, &rule22},+	{1146, 1, &rule21},+	{1147, 1, &rule22},+	{1148, 1, &rule21},+	{1149, 1, &rule22},+	{1150, 1, &rule21},+	{1151, 1, &rule22},+	{1152, 1, &rule21},+	{1153, 1, &rule22},+	{1162, 1, &rule21},+	{1163, 1, &rule22},+	{1164, 1, &rule21},+	{1165, 1, &rule22},+	{1166, 1, &rule21},+	{1167, 1, &rule22},+	{1168, 1, &rule21},+	{1169, 1, &rule22},+	{1170, 1, &rule21},+	{1171, 1, &rule22},+	{1172, 1, &rule21},+	{1173, 1, &rule22},+	{1174, 1, &rule21},+	{1175, 1, &rule22},+	{1176, 1, &rule21},+	{1177, 1, &rule22},+	{1178, 1, &rule21},+	{1179, 1, &rule22},+	{1180, 1, &rule21},+	{1181, 1, &rule22},+	{1182, 1, &rule21},+	{1183, 1, &rule22},+	{1184, 1, &rule21},+	{1185, 1, &rule22},+	{1186, 1, &rule21},+	{1187, 1, &rule22},+	{1188, 1, &rule21},+	{1189, 1, &rule22},+	{1190, 1, &rule21},+	{1191, 1, &rule22},+	{1192, 1, &rule21},+	{1193, 1, &rule22},+	{1194, 1, &rule21},+	{1195, 1, &rule22},+	{1196, 1, &rule21},+	{1197, 1, &rule22},+	{1198, 1, &rule21},+	{1199, 1, &rule22},+	{1200, 1, &rule21},+	{1201, 1, &rule22},+	{1202, 1, &rule21},+	{1203, 1, &rule22},+	{1204, 1, &rule21},+	{1205, 1, &rule22},+	{1206, 1, &rule21},+	{1207, 1, &rule22},+	{1208, 1, &rule21},+	{1209, 1, &rule22},+	{1210, 1, &rule21},+	{1211, 1, &rule22},+	{1212, 1, &rule21},+	{1213, 1, &rule22},+	{1214, 1, &rule21},+	{1215, 1, &rule22},+	{1216, 1, &rule107},+	{1217, 1, &rule21},+	{1218, 1, &rule22},+	{1219, 1, &rule21},+	{1220, 1, &rule22},+	{1221, 1, &rule21},+	{1222, 1, &rule22},+	{1223, 1, &rule21},+	{1224, 1, &rule22},+	{1225, 1, &rule21},+	{1226, 1, &rule22},+	{1227, 1, &rule21},+	{1228, 1, &rule22},+	{1229, 1, &rule21},+	{1230, 1, &rule22},+	{1231, 1, &rule108},+	{1232, 1, &rule21},+	{1233, 1, &rule22},+	{1234, 1, &rule21},+	{1235, 1, &rule22},+	{1236, 1, &rule21},+	{1237, 1, &rule22},+	{1238, 1, &rule21},+	{1239, 1, &rule22},+	{1240, 1, &rule21},+	{1241, 1, &rule22},+	{1242, 1, &rule21},+	{1243, 1, &rule22},+	{1244, 1, &rule21},+	{1245, 1, &rule22},+	{1246, 1, &rule21},+	{1247, 1, &rule22},+	{1248, 1, &rule21},+	{1249, 1, &rule22},+	{1250, 1, &rule21},+	{1251, 1, &rule22},+	{1252, 1, &rule21},+	{1253, 1, &rule22},+	{1254, 1, &rule21},+	{1255, 1, &rule22},+	{1256, 1, &rule21},+	{1257, 1, &rule22},+	{1258, 1, &rule21},+	{1259, 1, &rule22},+	{1260, 1, &rule21},+	{1261, 1, &rule22},+	{1262, 1, &rule21},+	{1263, 1, &rule22},+	{1264, 1, &rule21},+	{1265, 1, &rule22},+	{1266, 1, &rule21},+	{1267, 1, &rule22},+	{1268, 1, &rule21},+	{1269, 1, &rule22},+	{1270, 1, &rule21},+	{1271, 1, &rule22},+	{1272, 1, &rule21},+	{1273, 1, &rule22},+	{1274, 1, &rule21},+	{1275, 1, &rule22},+	{1276, 1, &rule21},+	{1277, 1, &rule22},+	{1278, 1, &rule21},+	{1279, 1, &rule22},+	{1280, 1, &rule21},+	{1281, 1, &rule22},+	{1282, 1, &rule21},+	{1283, 1, &rule22},+	{1284, 1, &rule21},+	{1285, 1, &rule22},+	{1286, 1, &rule21},+	{1287, 1, &rule22},+	{1288, 1, &rule21},+	{1289, 1, &rule22},+	{1290, 1, &rule21},+	{1291, 1, &rule22},+	{1292, 1, &rule21},+	{1293, 1, &rule22},+	{1294, 1, &rule21},+	{1295, 1, &rule22},+	{1296, 1, &rule21},+	{1297, 1, &rule22},+	{1298, 1, &rule21},+	{1299, 1, &rule22},+	{1300, 1, &rule21},+	{1301, 1, &rule22},+	{1302, 1, &rule21},+	{1303, 1, &rule22},+	{1304, 1, &rule21},+	{1305, 1, &rule22},+	{1306, 1, &rule21},+	{1307, 1, &rule22},+	{1308, 1, &rule21},+	{1309, 1, &rule22},+	{1310, 1, &rule21},+	{1311, 1, &rule22},+	{1312, 1, &rule21},+	{1313, 1, &rule22},+	{1314, 1, &rule21},+	{1315, 1, &rule22},+	{1329, 38, &rule109},+	{1377, 38, &rule110},+	{4256, 38, &rule112},+	{7545, 1, &rule114},+	{7549, 1, &rule115},+	{7680, 1, &rule21},+	{7681, 1, &rule22},+	{7682, 1, &rule21},+	{7683, 1, &rule22},+	{7684, 1, &rule21},+	{7685, 1, &rule22},+	{7686, 1, &rule21},+	{7687, 1, &rule22},+	{7688, 1, &rule21},+	{7689, 1, &rule22},+	{7690, 1, &rule21},+	{7691, 1, &rule22},+	{7692, 1, &rule21},+	{7693, 1, &rule22},+	{7694, 1, &rule21},+	{7695, 1, &rule22},+	{7696, 1, &rule21},+	{7697, 1, &rule22},+	{7698, 1, &rule21},+	{7699, 1, &rule22},+	{7700, 1, &rule21},+	{7701, 1, &rule22},+	{7702, 1, &rule21},+	{7703, 1, &rule22},+	{7704, 1, &rule21},+	{7705, 1, &rule22},+	{7706, 1, &rule21},+	{7707, 1, &rule22},+	{7708, 1, &rule21},+	{7709, 1, &rule22},+	{7710, 1, &rule21},+	{7711, 1, &rule22},+	{7712, 1, &rule21},+	{7713, 1, &rule22},+	{7714, 1, &rule21},+	{7715, 1, &rule22},+	{7716, 1, &rule21},+	{7717, 1, &rule22},+	{7718, 1, &rule21},+	{7719, 1, &rule22},+	{7720, 1, &rule21},+	{7721, 1, &rule22},+	{7722, 1, &rule21},+	{7723, 1, &rule22},+	{7724, 1, &rule21},+	{7725, 1, &rule22},+	{7726, 1, &rule21},+	{7727, 1, &rule22},+	{7728, 1, &rule21},+	{7729, 1, &rule22},+	{7730, 1, &rule21},+	{7731, 1, &rule22},+	{7732, 1, &rule21},+	{7733, 1, &rule22},+	{7734, 1, &rule21},+	{7735, 1, &rule22},+	{7736, 1, &rule21},+	{7737, 1, &rule22},+	{7738, 1, &rule21},+	{7739, 1, &rule22},+	{7740, 1, &rule21},+	{7741, 1, &rule22},+	{7742, 1, &rule21},+	{7743, 1, &rule22},+	{7744, 1, &rule21},+	{7745, 1, &rule22},+	{7746, 1, &rule21},+	{7747, 1, &rule22},+	{7748, 1, &rule21},+	{7749, 1, &rule22},+	{7750, 1, &rule21},+	{7751, 1, &rule22},+	{7752, 1, &rule21},+	{7753, 1, &rule22},+	{7754, 1, &rule21},+	{7755, 1, &rule22},+	{7756, 1, &rule21},+	{7757, 1, &rule22},+	{7758, 1, &rule21},+	{7759, 1, &rule22},+	{7760, 1, &rule21},+	{7761, 1, &rule22},+	{7762, 1, &rule21},+	{7763, 1, &rule22},+	{7764, 1, &rule21},+	{7765, 1, &rule22},+	{7766, 1, &rule21},+	{7767, 1, &rule22},+	{7768, 1, &rule21},+	{7769, 1, &rule22},+	{7770, 1, &rule21},+	{7771, 1, &rule22},+	{7772, 1, &rule21},+	{7773, 1, &rule22},+	{7774, 1, &rule21},+	{7775, 1, &rule22},+	{7776, 1, &rule21},+	{7777, 1, &rule22},+	{7778, 1, &rule21},+	{7779, 1, &rule22},+	{7780, 1, &rule21},+	{7781, 1, &rule22},+	{7782, 1, &rule21},+	{7783, 1, &rule22},+	{7784, 1, &rule21},+	{7785, 1, &rule22},+	{7786, 1, &rule21},+	{7787, 1, &rule22},+	{7788, 1, &rule21},+	{7789, 1, &rule22},+	{7790, 1, &rule21},+	{7791, 1, &rule22},+	{7792, 1, &rule21},+	{7793, 1, &rule22},+	{7794, 1, &rule21},+	{7795, 1, &rule22},+	{7796, 1, &rule21},+	{7797, 1, &rule22},+	{7798, 1, &rule21},+	{7799, 1, &rule22},+	{7800, 1, &rule21},+	{7801, 1, &rule22},+	{7802, 1, &rule21},+	{7803, 1, &rule22},+	{7804, 1, &rule21},+	{7805, 1, &rule22},+	{7806, 1, &rule21},+	{7807, 1, &rule22},+	{7808, 1, &rule21},+	{7809, 1, &rule22},+	{7810, 1, &rule21},+	{7811, 1, &rule22},+	{7812, 1, &rule21},+	{7813, 1, &rule22},+	{7814, 1, &rule21},+	{7815, 1, &rule22},+	{7816, 1, &rule21},+	{7817, 1, &rule22},+	{7818, 1, &rule21},+	{7819, 1, &rule22},+	{7820, 1, &rule21},+	{7821, 1, &rule22},+	{7822, 1, &rule21},+	{7823, 1, &rule22},+	{7824, 1, &rule21},+	{7825, 1, &rule22},+	{7826, 1, &rule21},+	{7827, 1, &rule22},+	{7828, 1, &rule21},+	{7829, 1, &rule22},+	{7835, 1, &rule116},+	{7838, 1, &rule117},+	{7840, 1, &rule21},+	{7841, 1, &rule22},+	{7842, 1, &rule21},+	{7843, 1, &rule22},+	{7844, 1, &rule21},+	{7845, 1, &rule22},+	{7846, 1, &rule21},+	{7847, 1, &rule22},+	{7848, 1, &rule21},+	{7849, 1, &rule22},+	{7850, 1, &rule21},+	{7851, 1, &rule22},+	{7852, 1, &rule21},+	{7853, 1, &rule22},+	{7854, 1, &rule21},+	{7855, 1, &rule22},+	{7856, 1, &rule21},+	{7857, 1, &rule22},+	{7858, 1, &rule21},+	{7859, 1, &rule22},+	{7860, 1, &rule21},+	{7861, 1, &rule22},+	{7862, 1, &rule21},+	{7863, 1, &rule22},+	{7864, 1, &rule21},+	{7865, 1, &rule22},+	{7866, 1, &rule21},+	{7867, 1, &rule22},+	{7868, 1, &rule21},+	{7869, 1, &rule22},+	{7870, 1, &rule21},+	{7871, 1, &rule22},+	{7872, 1, &rule21},+	{7873, 1, &rule22},+	{7874, 1, &rule21},+	{7875, 1, &rule22},+	{7876, 1, &rule21},+	{7877, 1, &rule22},+	{7878, 1, &rule21},+	{7879, 1, &rule22},+	{7880, 1, &rule21},+	{7881, 1, &rule22},+	{7882, 1, &rule21},+	{7883, 1, &rule22},+	{7884, 1, &rule21},+	{7885, 1, &rule22},+	{7886, 1, &rule21},+	{7887, 1, &rule22},+	{7888, 1, &rule21},+	{7889, 1, &rule22},+	{7890, 1, &rule21},+	{7891, 1, &rule22},+	{7892, 1, &rule21},+	{7893, 1, &rule22},+	{7894, 1, &rule21},+	{7895, 1, &rule22},+	{7896, 1, &rule21},+	{7897, 1, &rule22},+	{7898, 1, &rule21},+	{7899, 1, &rule22},+	{7900, 1, &rule21},+	{7901, 1, &rule22},+	{7902, 1, &rule21},+	{7903, 1, &rule22},+	{7904, 1, &rule21},+	{7905, 1, &rule22},+	{7906, 1, &rule21},+	{7907, 1, &rule22},+	{7908, 1, &rule21},+	{7909, 1, &rule22},+	{7910, 1, &rule21},+	{7911, 1, &rule22},+	{7912, 1, &rule21},+	{7913, 1, &rule22},+	{7914, 1, &rule21},+	{7915, 1, &rule22},+	{7916, 1, &rule21},+	{7917, 1, &rule22},+	{7918, 1, &rule21},+	{7919, 1, &rule22},+	{7920, 1, &rule21},+	{7921, 1, &rule22},+	{7922, 1, &rule21},+	{7923, 1, &rule22},+	{7924, 1, &rule21},+	{7925, 1, &rule22},+	{7926, 1, &rule21},+	{7927, 1, &rule22},+	{7928, 1, &rule21},+	{7929, 1, &rule22},+	{7930, 1, &rule21},+	{7931, 1, &rule22},+	{7932, 1, &rule21},+	{7933, 1, &rule22},+	{7934, 1, &rule21},+	{7935, 1, &rule22},+	{7936, 8, &rule118},+	{7944, 8, &rule119},+	{7952, 6, &rule118},+	{7960, 6, &rule119},+	{7968, 8, &rule118},+	{7976, 8, &rule119},+	{7984, 8, &rule118},+	{7992, 8, &rule119},+	{8000, 6, &rule118},+	{8008, 6, &rule119},+	{8017, 1, &rule118},+	{8019, 1, &rule118},+	{8021, 1, &rule118},+	{8023, 1, &rule118},+	{8025, 1, &rule119},+	{8027, 1, &rule119},+	{8029, 1, &rule119},+	{8031, 1, &rule119},+	{8032, 8, &rule118},+	{8040, 8, &rule119},+	{8048, 2, &rule120},+	{8050, 4, &rule121},+	{8054, 2, &rule122},+	{8056, 2, &rule123},+	{8058, 2, &rule124},+	{8060, 2, &rule125},+	{8064, 8, &rule118},+	{8072, 8, &rule126},+	{8080, 8, &rule118},+	{8088, 8, &rule126},+	{8096, 8, &rule118},+	{8104, 8, &rule126},+	{8112, 2, &rule118},+	{8115, 1, &rule127},+	{8120, 2, &rule119},+	{8122, 2, &rule128},+	{8124, 1, &rule129},+	{8126, 1, &rule130},+	{8131, 1, &rule127},+	{8136, 4, &rule131},+	{8140, 1, &rule129},+	{8144, 2, &rule118},+	{8152, 2, &rule119},+	{8154, 2, &rule132},+	{8160, 2, &rule118},+	{8165, 1, &rule101},+	{8168, 2, &rule119},+	{8170, 2, &rule133},+	{8172, 1, &rule104},+	{8179, 1, &rule127},+	{8184, 2, &rule134},+	{8186, 2, &rule135},+	{8188, 1, &rule129},+	{8486, 1, &rule138},+	{8490, 1, &rule139},+	{8491, 1, &rule140},+	{8498, 1, &rule141},+	{8526, 1, &rule142},+	{8544, 16, &rule143},+	{8560, 16, &rule144},+	{8579, 1, &rule21},+	{8580, 1, &rule22},+	{9398, 26, &rule145},+	{9424, 26, &rule146},+	{11264, 47, &rule109},+	{11312, 47, &rule110},+	{11360, 1, &rule21},+	{11361, 1, &rule22},+	{11362, 1, &rule147},+	{11363, 1, &rule148},+	{11364, 1, &rule149},+	{11365, 1, &rule150},+	{11366, 1, &rule151},+	{11367, 1, &rule21},+	{11368, 1, &rule22},+	{11369, 1, &rule21},+	{11370, 1, &rule22},+	{11371, 1, &rule21},+	{11372, 1, &rule22},+	{11373, 1, &rule152},+	{11374, 1, &rule153},+	{11375, 1, &rule154},+	{11378, 1, &rule21},+	{11379, 1, &rule22},+	{11381, 1, &rule21},+	{11382, 1, &rule22},+	{11392, 1, &rule21},+	{11393, 1, &rule22},+	{11394, 1, &rule21},+	{11395, 1, &rule22},+	{11396, 1, &rule21},+	{11397, 1, &rule22},+	{11398, 1, &rule21},+	{11399, 1, &rule22},+	{11400, 1, &rule21},+	{11401, 1, &rule22},+	{11402, 1, &rule21},+	{11403, 1, &rule22},+	{11404, 1, &rule21},+	{11405, 1, &rule22},+	{11406, 1, &rule21},+	{11407, 1, &rule22},+	{11408, 1, &rule21},+	{11409, 1, &rule22},+	{11410, 1, &rule21},+	{11411, 1, &rule22},+	{11412, 1, &rule21},+	{11413, 1, &rule22},+	{11414, 1, &rule21},+	{11415, 1, &rule22},+	{11416, 1, &rule21},+	{11417, 1, &rule22},+	{11418, 1, &rule21},+	{11419, 1, &rule22},+	{11420, 1, &rule21},+	{11421, 1, &rule22},+	{11422, 1, &rule21},+	{11423, 1, &rule22},+	{11424, 1, &rule21},+	{11425, 1, &rule22},+	{11426, 1, &rule21},+	{11427, 1, &rule22},+	{11428, 1, &rule21},+	{11429, 1, &rule22},+	{11430, 1, &rule21},+	{11431, 1, &rule22},+	{11432, 1, &rule21},+	{11433, 1, &rule22},+	{11434, 1, &rule21},+	{11435, 1, &rule22},+	{11436, 1, &rule21},+	{11437, 1, &rule22},+	{11438, 1, &rule21},+	{11439, 1, &rule22},+	{11440, 1, &rule21},+	{11441, 1, &rule22},+	{11442, 1, &rule21},+	{11443, 1, &rule22},+	{11444, 1, &rule21},+	{11445, 1, &rule22},+	{11446, 1, &rule21},+	{11447, 1, &rule22},+	{11448, 1, &rule21},+	{11449, 1, &rule22},+	{11450, 1, &rule21},+	{11451, 1, &rule22},+	{11452, 1, &rule21},+	{11453, 1, &rule22},+	{11454, 1, &rule21},+	{11455, 1, &rule22},+	{11456, 1, &rule21},+	{11457, 1, &rule22},+	{11458, 1, &rule21},+	{11459, 1, &rule22},+	{11460, 1, &rule21},+	{11461, 1, &rule22},+	{11462, 1, &rule21},+	{11463, 1, &rule22},+	{11464, 1, &rule21},+	{11465, 1, &rule22},+	{11466, 1, &rule21},+	{11467, 1, &rule22},+	{11468, 1, &rule21},+	{11469, 1, &rule22},+	{11470, 1, &rule21},+	{11471, 1, &rule22},+	{11472, 1, &rule21},+	{11473, 1, &rule22},+	{11474, 1, &rule21},+	{11475, 1, &rule22},+	{11476, 1, &rule21},+	{11477, 1, &rule22},+	{11478, 1, &rule21},+	{11479, 1, &rule22},+	{11480, 1, &rule21},+	{11481, 1, &rule22},+	{11482, 1, &rule21},+	{11483, 1, &rule22},+	{11484, 1, &rule21},+	{11485, 1, &rule22},+	{11486, 1, &rule21},+	{11487, 1, &rule22},+	{11488, 1, &rule21},+	{11489, 1, &rule22},+	{11490, 1, &rule21},+	{11491, 1, &rule22},+	{11520, 38, &rule155},+	{42560, 1, &rule21},+	{42561, 1, &rule22},+	{42562, 1, &rule21},+	{42563, 1, &rule22},+	{42564, 1, &rule21},+	{42565, 1, &rule22},+	{42566, 1, &rule21},+	{42567, 1, &rule22},+	{42568, 1, &rule21},+	{42569, 1, &rule22},+	{42570, 1, &rule21},+	{42571, 1, &rule22},+	{42572, 1, &rule21},+	{42573, 1, &rule22},+	{42574, 1, &rule21},+	{42575, 1, &rule22},+	{42576, 1, &rule21},+	{42577, 1, &rule22},+	{42578, 1, &rule21},+	{42579, 1, &rule22},+	{42580, 1, &rule21},+	{42581, 1, &rule22},+	{42582, 1, &rule21},+	{42583, 1, &rule22},+	{42584, 1, &rule21},+	{42585, 1, &rule22},+	{42586, 1, &rule21},+	{42587, 1, &rule22},+	{42588, 1, &rule21},+	{42589, 1, &rule22},+	{42590, 1, &rule21},+	{42591, 1, &rule22},+	{42594, 1, &rule21},+	{42595, 1, &rule22},+	{42596, 1, &rule21},+	{42597, 1, &rule22},+	{42598, 1, &rule21},+	{42599, 1, &rule22},+	{42600, 1, &rule21},+	{42601, 1, &rule22},+	{42602, 1, &rule21},+	{42603, 1, &rule22},+	{42604, 1, &rule21},+	{42605, 1, &rule22},+	{42624, 1, &rule21},+	{42625, 1, &rule22},+	{42626, 1, &rule21},+	{42627, 1, &rule22},+	{42628, 1, &rule21},+	{42629, 1, &rule22},+	{42630, 1, &rule21},+	{42631, 1, &rule22},+	{42632, 1, &rule21},+	{42633, 1, &rule22},+	{42634, 1, &rule21},+	{42635, 1, &rule22},+	{42636, 1, &rule21},+	{42637, 1, &rule22},+	{42638, 1, &rule21},+	{42639, 1, &rule22},+	{42640, 1, &rule21},+	{42641, 1, &rule22},+	{42642, 1, &rule21},+	{42643, 1, &rule22},+	{42644, 1, &rule21},+	{42645, 1, &rule22},+	{42646, 1, &rule21},+	{42647, 1, &rule22},+	{42786, 1, &rule21},+	{42787, 1, &rule22},+	{42788, 1, &rule21},+	{42789, 1, &rule22},+	{42790, 1, &rule21},+	{42791, 1, &rule22},+	{42792, 1, &rule21},+	{42793, 1, &rule22},+	{42794, 1, &rule21},+	{42795, 1, &rule22},+	{42796, 1, &rule21},+	{42797, 1, &rule22},+	{42798, 1, &rule21},+	{42799, 1, &rule22},+	{42802, 1, &rule21},+	{42803, 1, &rule22},+	{42804, 1, &rule21},+	{42805, 1, &rule22},+	{42806, 1, &rule21},+	{42807, 1, &rule22},+	{42808, 1, &rule21},+	{42809, 1, &rule22},+	{42810, 1, &rule21},+	{42811, 1, &rule22},+	{42812, 1, &rule21},+	{42813, 1, &rule22},+	{42814, 1, &rule21},+	{42815, 1, &rule22},+	{42816, 1, &rule21},+	{42817, 1, &rule22},+	{42818, 1, &rule21},+	{42819, 1, &rule22},+	{42820, 1, &rule21},+	{42821, 1, &rule22},+	{42822, 1, &rule21},+	{42823, 1, &rule22},+	{42824, 1, &rule21},+	{42825, 1, &rule22},+	{42826, 1, &rule21},+	{42827, 1, &rule22},+	{42828, 1, &rule21},+	{42829, 1, &rule22},+	{42830, 1, &rule21},+	{42831, 1, &rule22},+	{42832, 1, &rule21},+	{42833, 1, &rule22},+	{42834, 1, &rule21},+	{42835, 1, &rule22},+	{42836, 1, &rule21},+	{42837, 1, &rule22},+	{42838, 1, &rule21},+	{42839, 1, &rule22},+	{42840, 1, &rule21},+	{42841, 1, &rule22},+	{42842, 1, &rule21},+	{42843, 1, &rule22},+	{42844, 1, &rule21},+	{42845, 1, &rule22},+	{42846, 1, &rule21},+	{42847, 1, &rule22},+	{42848, 1, &rule21},+	{42849, 1, &rule22},+	{42850, 1, &rule21},+	{42851, 1, &rule22},+	{42852, 1, &rule21},+	{42853, 1, &rule22},+	{42854, 1, &rule21},+	{42855, 1, &rule22},+	{42856, 1, &rule21},+	{42857, 1, &rule22},+	{42858, 1, &rule21},+	{42859, 1, &rule22},+	{42860, 1, &rule21},+	{42861, 1, &rule22},+	{42862, 1, &rule21},+	{42863, 1, &rule22},+	{42873, 1, &rule21},+	{42874, 1, &rule22},+	{42875, 1, &rule21},+	{42876, 1, &rule22},+	{42877, 1, &rule156},+	{42878, 1, &rule21},+	{42879, 1, &rule22},+	{42880, 1, &rule21},+	{42881, 1, &rule22},+	{42882, 1, &rule21},+	{42883, 1, &rule22},+	{42884, 1, &rule21},+	{42885, 1, &rule22},+	{42886, 1, &rule21},+	{42887, 1, &rule22},+	{42891, 1, &rule21},+	{42892, 1, &rule22},+	{65313, 26, &rule9},+	{65345, 26, &rule12},+	{66560, 40, &rule159},+	{66600, 40, &rule160}+};+static const struct _charblock_ spacechars[]={+	{32, 1, &rule1},+	{160, 1, &rule1},+	{5760, 1, &rule1},+	{6158, 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};++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) \+int p(int c) \+{ \+	return checkattr(c,m); \+}++#define unipred_s(p,m) \+int p(int 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_MC|GENCAT_ME|GENCAT_MN|+		    GENCAT_NO|GENCAT_ND|GENCAT_NL))++#define caseconv(p,to) \+int p(int 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)++int u_gencat(int c)+{+	return getrule(allchars,NUM_BLOCKS,c)->catnumber;+}+
+ cbits/Win32Utils.c view
@@ -0,0 +1,123 @@+/* ----------------------------------------------------------------------------+   (c) The University of Glasgow 2006+   +   Useful Win32 bits+   ------------------------------------------------------------------------- */++#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)++#include "HsBase.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 */+        {  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)+{+	int i;+	DWORD dwErrorCode;++	dwErrorCode = GetLastError();++	/* check the table for the OS error code */+	for (i = 0; i < ERRTABLESIZE; ++i)+	{+		if (dwErrorCode == errtable[i].oscode)+		{+			errno = errtable[i].errnocode;+			return;+		}+	}++	/* 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)+		errno = EACCES;+	else+		if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)+			errno = ENOEXEC;+		else+			errno = EINVAL;+}++HsWord64 getUSecOfDay(void)+{+    HsWord64 t;+    FILETIME ft;+    GetSystemTimeAsFileTime(&ft);+    t = ((HsWord64)ft.dwHighDateTime << 32) | ft.dwLowDateTime;+    t = t / 10LL;+    /* FILETIMES are in units of 100ns,+       so we divide by 10 to get microseconds */+    return t;+}++#endif+
+ cbits/consUtils.c view
@@ -0,0 +1,88 @@+/* + * (c) The University of Glasgow 2002+ *+ * Win32 Console API support+ */+#if defined(_MSC_VER) || defined(__MINGW32__) || 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+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;+}++int+flush_input_console__(int fd)+{+    HANDLE h = (HANDLE)_get_osfhandle(fd);+    +    if ( h != INVALID_HANDLE_VALUE ) {+	/* If the 'fd' isn't connected to a console; treat the flush+	 * operation as a NOP.+	 */+	DWORD unused;+	if ( !GetConsoleMode(h,&unused) &&+	     GetLastError() == ERROR_INVALID_HANDLE ) {+	    return 0;+	}+	if ( FlushConsoleInputBuffer(h) ) {+	    return 0;+	}+    }+    /* ToDo: translate GetLastError() into something errno-friendly */+    return -1;+}++#endif /* defined(__MINGW32__) || ... */
+ cbits/dirUtils.c view
@@ -0,0 +1,72 @@+/* + * (c) The University of Glasgow 2002+ *+ * Directory Runtime Support+ */++/* needed only for solaris2_HOST_OS */+#include "ghcconfig.h"++// The following is required on Solaris to force the POSIX versions of+// the various _r functions instead of the Solaris versions.+#ifdef solaris2_HOST_OS+#define _POSIX_PTHREAD_SEMANTICS+#endif++#include "HsBase.h"++#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+#include <windows.h>+#endif+++/*+ * read an entry from the directory stream; opt for the+ * re-entrant friendly way of doing this, if available.+ */+int+__hscore_readdir( DIR *dirPtr, struct dirent **pDirEnt )+{+#if HAVE_READDIR_R+  struct dirent* p;+  int res;+  static unsigned int nm_max = (unsigned int)-1;+  +  if (pDirEnt == NULL) {+    return -1;+  }+  if (nm_max == (unsigned int)-1) {+#ifdef NAME_MAX+    nm_max = NAME_MAX + 1;+#else+    nm_max = pathconf(".", _PC_NAME_MAX);+    if (nm_max == -1) { nm_max = 255; }+    nm_max++;+#endif+  }+  p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max);+  if (p == NULL) return -1;+  res = readdir_r(dirPtr, p, pDirEnt);+  if (res != 0) {+      *pDirEnt = NULL;+      free(p);+  }+  else if (*pDirEnt == NULL) {+    // end of stream+    free(p);+  }+  return res;+#else++  if (pDirEnt == NULL) {+    return -1;+  }++  *pDirEnt = readdir(dirPtr);+  if (*pDirEnt == NULL) {+    return -1;+  } else {+    return 0;+  }  +#endif+}
+ cbits/inputReady.c view
@@ -0,0 +1,168 @@+/* + * (c) The GRASP/AQUA Project, Glasgow University, 1994-2002+ *+ * hWaitForInput Runtime Support+ */++/* select and supporting types is not Posix */+/* #include "PosixSource.h" */+#include "HsBase.h"++/*+ * inputReady(fd) checks to see whether input is available on the file+ * descriptor 'fd'.  Input meaning 'can I safely read at least a+ * *character* from this file object without blocking?'+ */+int+fdReady(int fd, int write, int msecs, int isSock)+{+    if +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+    ( isSock ) {+#else+    ( 1 ) {+#endif+	int maxfd, ready;+	fd_set rfd, wfd;+	struct timeval tv;+	+	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;+	tv.tv_sec  = msecs / 1000;+	tv.tv_usec = (msecs % 1000) * 1000;+	+	while ((ready = select(maxfd, &rfd, &wfd, NULL, &tv)) < 0 ) {+	    if (errno != EINTR ) {+		return -1;+	    }+	}+	+	/* 1 => Input ready, 0 => not ready, -1 => error */+	return (ready);+    }+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+    else {+	DWORD rc;+	HANDLE hFile = (HANDLE)_get_osfhandle(fd);+	DWORD avail;++        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, msecs );+                switch (rc) {+                case WAIT_TIMEOUT: return 0;+                case WAIT_OBJECT_0: break;+                default: /* WAIT_FAILED */ maperrno(); return -1;+                }++                while (1) // discard non-key events+                {+                    rc = PeekConsoleInput(hFile, buf, 1, &count);+                    // printf("peek, rc=%d, count=%d, type=%d\n", rc, count, buf[0].EventType);+                    if (rc == 0) {+                        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.+                        rc = ReadConsoleInput(hFile, buf, 1, &count);+                        if (rc == 0) {+                            rc = GetLastError();+                            if (rc == ERROR_INVALID_HANDLE || rc == ERROR_INVALID_FUNCTION) {+                                return 1;+                            } else {+                                maperrno();+                                return -1;+                            }+                        }+                    }+                }+            }+        }++        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:+            //+            rc = PeekNamedPipe( hFile, NULL, 0, NULL, &avail, NULL );+            if (rc != 0) {+                if (avail != 0) {+                    return 1;+                } else {+                    return 0;+                }+            } 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:+            rc = WaitForSingleObject( hFile, msecs );++            /* 1 => Input ready, 0 => not ready, -1 => error */+            switch (rc) {+            case WAIT_TIMEOUT: return 0;+            case WAIT_OBJECT_0: return 1;+            default: /* WAIT_FAILED */ maperrno(); return -1;+            }+        }+    }+#endif+}
+ cbits/selectUtils.c view
@@ -0,0 +1,3 @@++#include "HsBase.h"+void hsFD_ZERO(fd_set *fds) { FD_ZERO(fds); }
+ config.guess view
@@ -0,0 +1,1526 @@+#! /bin/sh+# Attempt to guess a canonical system name.+#   Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,+#   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008+#   Free Software Foundation, Inc.++timestamp='2008-01-23'++# 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 2 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, write to the Free Software+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA+# 02110-1301, USA.+#+# 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.+++# Originally written by Per Bothner <per@bothner.com>.+# Please send patches to <config-patches@gnu.org>.  Submit a context+# diff and a properly formatted ChangeLog entry.+#+# This script attempts to guess a canonical system name similar to+# config.sub.  If it succeeds, it prints the system name on stdout, and+# exits with 0.  Otherwise, it exits with 1.+#+# The plan is that this can be called by configure scripts if you+# don't specify an explicit build system type.++me=`echo "$0" | sed -e 's,.*/,,'`++usage="\+Usage: $0 [OPTION]++Output the configuration name of the system \`$me' is run on.++Operation modes:+  -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 (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,+2002, 2003, 2004, 2005, 2006, 2007, 2008 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++trap 'exit 1' 1 2 15++# 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.++set_cc_for_build='+trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;+trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;+: ${TMPDIR=/tmp} ;+ { 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) ; } ||+ { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||+ { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;+dummy=$tmp/dummy ;+tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ;+case $CC_FOR_BUILD,$HOST_CC,$CC in+ ,,)    echo "int x;" > $dummy.c ;+	for c in cc gcc c89 c99 ; do+	  if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then+	     CC_FOR_BUILD="$c"; 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 ; set_cc_for_build= ;'++# 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) >/dev/null 2>&1 ; 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++# 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 tupples: *-*-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".+	sysctl="sysctl -n hw.machine_arch"+	UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \+	    /usr/sbin/$sysctl 2>/dev/null || echo unknown)`+	case "${UNAME_MACHINE_ARCH}" in+	    armeb) machine=armeb-unknown ;;+	    arm*) machine=arm-unknown ;;+	    sh3el) machine=shl-unknown ;;+	    sh3eb) machine=sh-unknown ;;+	    sh5el) machine=sh5le-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.+	case "${UNAME_MACHINE_ARCH}" in+	    arm*|i386|m68k|ns32k|sh3*|sparc|vax)+		eval $set_cc_for_build+		if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \+			| grep __ELF__ >/dev/null+		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+	# 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/[-_].*/\./'`+		;;+	esac+	# Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM:+	# contains redundant information, the shorter form:+	# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.+	echo "${machine}-${os}${release}"+	exit ;;+    *:OpenBSD:*:*)+	UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`+	echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}+	exit ;;+    *:ekkoBSD:*:*)+	echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}+	exit ;;+    *:SolidBSD:*:*)+	echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}+	exit ;;+    macppc:MirBSD:*:*)+	echo powerpc-unknown-mirbsd${UNAME_RELEASE}+	exit ;;+    *:MirBSD:*:*)+	echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}+	exit ;;+    alpha:OSF1:*:*)+	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.+	echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`+	exit ;;+    Alpha\ *:Windows_NT*:*)+	# How do we know it's Interix rather than the generic POSIX subsystem?+	# Should we change UNAME_MACHINE based on the output of uname instead+	# of the specific Alpha model?+	echo alpha-pc-interix+	exit ;;+    21064:Windows_NT:50:3)+	echo alpha-dec-winnt3.5+	exit ;;+    Amiga*:UNIX_System_V:4.0:*)+	echo m68k-unknown-sysv4+	exit ;;+    *:[Aa]miga[Oo][Ss]:*:*)+	echo ${UNAME_MACHINE}-unknown-amigaos+	exit ;;+    *:[Mm]orph[Oo][Ss]:*:*)+	echo ${UNAME_MACHINE}-unknown-morphos+	exit ;;+    *:OS/390:*:*)+	echo i370-ibm-openedition+	exit ;;+    *:z/VM:*:*)+	echo s390-ibm-zvmoe+	exit ;;+    *:OS400:*:*)+        echo powerpc-ibm-os400+	exit ;;+    arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)+	echo arm-acorn-riscix${UNAME_RELEASE}+	exit ;;+    arm:riscos:*:*|arm:RISCOS:*:*)+	echo arm-unknown-riscos+	exit ;;+    SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)+	echo hppa1.1-hitachi-hiuxmpp+	exit ;;+    Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)+	# akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.+	if test "`(/bin/universe) 2>/dev/null`" = att ; then+		echo pyramid-pyramid-sysv3+	else+		echo pyramid-pyramid-bsd+	fi+	exit ;;+    NILE*:*:*:dcosx)+	echo pyramid-pyramid-svr4+	exit ;;+    DRS?6000:unix:4.0:6*)+	echo sparc-icl-nx6+	exit ;;+    DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)+	case `/usr/bin/uname -p` in+	    sparc) echo sparc-icl-nx7; exit ;;+	esac ;;+    sun4H:SunOS:5.*:*)+	echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+	exit ;;+    sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)+	echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+	exit ;;+    i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)+	echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+	exit ;;+    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.+	echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+	exit ;;+    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'.+	echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`+	exit ;;+    sun3*:SunOS:*:*)+	echo m68k-sun-sunos${UNAME_RELEASE}+	exit ;;+    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)+		echo m68k-sun-sunos${UNAME_RELEASE}+		;;+	    sun4)+		echo sparc-sun-sunos${UNAME_RELEASE}+		;;+	esac+	exit ;;+    aushp:SunOS:*:*)+	echo sparc-auspex-sunos${UNAME_RELEASE}+	exit ;;+    # 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:*:*)+        echo m68k-atari-mint${UNAME_RELEASE}+	exit ;;+    atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)+	echo m68k-atari-mint${UNAME_RELEASE}+        exit ;;+    *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)+        echo m68k-atari-mint${UNAME_RELEASE}+	exit ;;+    milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)+        echo m68k-milan-mint${UNAME_RELEASE}+        exit ;;+    hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)+        echo m68k-hades-mint${UNAME_RELEASE}+        exit ;;+    *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)+        echo m68k-unknown-mint${UNAME_RELEASE}+        exit ;;+    m68k:machten:*:*)+	echo m68k-apple-machten${UNAME_RELEASE}+	exit ;;+    powerpc:machten:*:*)+	echo powerpc-apple-machten${UNAME_RELEASE}+	exit ;;+    RISC*:Mach:*:*)+	echo mips-dec-mach_bsd4.3+	exit ;;+    RISC*:ULTRIX:*:*)+	echo mips-dec-ultrix${UNAME_RELEASE}+	exit ;;+    VAX*:ULTRIX*:*:*)+	echo vax-dec-ultrix${UNAME_RELEASE}+	exit ;;+    2020:CLIX:*:* | 2430:CLIX:*:*)+	echo clipper-intergraph-clix${UNAME_RELEASE}+	exit ;;+    mips:*:*:UMIPS | mips:*:*:RISCos)+	eval $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; }+	echo mips-mips-riscos${UNAME_RELEASE}+	exit ;;+    Motorola:PowerMAX_OS:*:*)+	echo powerpc-motorola-powermax+	exit ;;+    Motorola:*:4.3:PL8-*)+	echo powerpc-harris-powermax+	exit ;;+    Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)+	echo powerpc-harris-powermax+	exit ;;+    Night_Hawk:Power_UNIX:*:*)+	echo powerpc-harris-powerunix+	exit ;;+    m88k:CX/UX:7*:*)+	echo m88k-harris-cxux7+	exit ;;+    m88k:*:4*:R4*)+	echo m88k-motorola-sysv4+	exit ;;+    m88k:*:3*:R3*)+	echo m88k-motorola-sysv3+	exit ;;+    AViiON:dgux:*:*)+        # DG/UX returns AViiON for all architectures+        UNAME_PROCESSOR=`/usr/bin/uname -p`+	if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]+	then+	    if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \+	       [ ${TARGET_BINARY_INTERFACE}x = x ]+	    then+		echo m88k-dg-dgux${UNAME_RELEASE}+	    else+		echo m88k-dg-dguxbcs${UNAME_RELEASE}+	    fi+	else+	    echo i586-dg-dgux${UNAME_RELEASE}+	fi+ 	exit ;;+    M88*:DolphinOS:*:*)	# DolphinOS (SVR3)+	echo m88k-dolphin-sysv3+	exit ;;+    M88*:*:R3*:*)+	# Delta 88k system running SVR3+	echo m88k-motorola-sysv3+	exit ;;+    XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)+	echo m88k-tektronix-sysv3+	exit ;;+    Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)+	echo m68k-tektronix-bsd+	exit ;;+    *:IRIX*:*:*)+	echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`+	exit ;;+    ????????:AIX?:[12].1:2)   # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.+	echo romp-ibm-aix     # uname -m gives an 8 hex-code CPU id+	exit ;;               # Note that: echo "'`uname -s`'" gives 'AIX '+    i*86:AIX:*:*)+	echo i386-ibm-aix+	exit ;;+    ia64:AIX:*:*)+	if [ -x /usr/bin/oslevel ] ; then+		IBM_REV=`/usr/bin/oslevel`+	else+		IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}+	fi+	echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}+	exit ;;+    *:AIX:2:3)+	if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then+		eval $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+			echo "$SYSTEM_NAME"+		else+			echo rs6000-ibm-aix3.2.5+		fi+	elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then+		echo rs6000-ibm-aix3.2.4+	else+		echo rs6000-ibm-aix3.2+	fi+	exit ;;+    *:AIX:*:[456])+	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 [ -x /usr/bin/oslevel ] ; then+		IBM_REV=`/usr/bin/oslevel`+	else+		IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}+	fi+	echo ${IBM_ARCH}-ibm-aix${IBM_REV}+	exit ;;+    *:AIX:*:*)+	echo rs6000-ibm-aix+	exit ;;+    ibmrt:4.4BSD:*|romp-ibm:BSD:*)+	echo romp-ibm-bsd4.4+	exit ;;+    ibmrt:*BSD:*|romp-ibm:BSD:*)            # covers RT/PC BSD and+	echo romp-ibm-bsd${UNAME_RELEASE}   # 4.3 with uname added to+	exit ;;                             # report: romp-ibm BSD 4.3+    *:BOSX:*:*)+	echo rs6000-bull-bosx+	exit ;;+    DPX/2?00:B.O.S.:*:*)+	echo m68k-bull-sysv3+	exit ;;+    9000/[34]??:4.3bsd:1.*:*)+	echo m68k-hp-bsd+	exit ;;+    hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)+	echo m68k-hp-bsd4.4+	exit ;;+    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 [ -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 [ "${HP_ARCH}" = "" ]; then+		    eval $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 [ ${HP_ARCH} = "hppa2.0w" ]+	then+	    eval $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 __LP64__ >/dev/null+	    then+		HP_ARCH="hppa2.0w"+	    else+		HP_ARCH="hppa64"+	    fi+	fi+	echo ${HP_ARCH}-hp-hpux${HPUX_REV}+	exit ;;+    ia64:HP-UX:*:*)+	HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`+	echo ia64-hp-hpux${HPUX_REV}+	exit ;;+    3050*:HI-UX:*:*)+	eval $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; }+	echo unknown-hitachi-hiuxwe2+	exit ;;+    9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )+	echo hppa1.1-hp-bsd+	exit ;;+    9000/8??:4.3bsd:*:*)+	echo hppa1.0-hp-bsd+	exit ;;+    *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)+	echo hppa1.0-hp-mpeix+	exit ;;+    hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )+	echo hppa1.1-hp-osf+	exit ;;+    hp8??:OSF1:*:*)+	echo hppa1.0-hp-osf+	exit ;;+    i*86:OSF1:*:*)+	if [ -x /usr/sbin/sysversion ] ; then+	    echo ${UNAME_MACHINE}-unknown-osf1mk+	else+	    echo ${UNAME_MACHINE}-unknown-osf1+	fi+	exit ;;+    parisc*:Lites*:*:*)+	echo hppa1.1-hp-lites+	exit ;;+    C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)+	echo c1-convex-bsd+        exit ;;+    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*:*)+	echo c34-convex-bsd+        exit ;;+    C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)+	echo c38-convex-bsd+        exit ;;+    C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)+	echo c4-convex-bsd+        exit ;;+    CRAY*Y-MP:*:*:*)+	echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+	exit ;;+    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:*:*:*)+	echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+	exit ;;+    CRAY*T3E:*:*:*)+	echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+	exit ;;+    CRAY*SV1:*:*:*)+	echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+	exit ;;+    *:UNICOS/mp:*:*)+	echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'+	exit ;;+    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/ /_/'`+        echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"+        exit ;;+    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/ /_/'`+        echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"+	exit ;;+    i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)+	echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}+	exit ;;+    sparc*:BSD/OS:*:*)+	echo sparc-unknown-bsdi${UNAME_RELEASE}+	exit ;;+    *:BSD/OS:*:*)+	echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}+	exit ;;+    *:FreeBSD:*:*)+	case ${UNAME_MACHINE} in+	    pc98)+		echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+	    amd64)+		echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+	    *)+		echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;+	esac+	exit ;;+    i*:CYGWIN*:*)+	echo ${UNAME_MACHINE}-pc-cygwin+	exit ;;+    *:MINGW*:*)+	echo ${UNAME_MACHINE}-pc-mingw32+	exit ;;+    i*:windows32*:*)+    	# uname -m includes "-pc" on this system.+    	echo ${UNAME_MACHINE}-mingw32+	exit ;;+    i*:PW*:*)+	echo ${UNAME_MACHINE}-pc-pw32+	exit ;;+    *:Interix*:[3456]*)+    	case ${UNAME_MACHINE} in+	    x86)+		echo i586-pc-interix${UNAME_RELEASE}+		exit ;;+	    EM64T | authenticamd)+		echo x86_64-unknown-interix${UNAME_RELEASE}+		exit ;;+	    IA64)+		echo ia64-unknown-interix${UNAME_RELEASE}+		exit ;;+	esac ;;+    [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)+	echo i${UNAME_MACHINE}-pc-mks+	exit ;;+    i*:Windows_NT*:* | Pentium*:Windows_NT*:*)+	# How do we know it's Interix rather than the generic POSIX subsystem?+	# It also conflicts with pre-2.0 versions of AT&T UWIN. Should we+	# UNAME_MACHINE based on the output of uname instead of i386?+	echo i586-pc-interix+	exit ;;+    i*:UWIN*:*)+	echo ${UNAME_MACHINE}-pc-uwin+	exit ;;+    amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)+	echo x86_64-unknown-cygwin+	exit ;;+    p*:CYGWIN*:*)+	echo powerpcle-unknown-cygwin+	exit ;;+    prep*:SunOS:5.*:*)+	echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`+	exit ;;+    *:GNU:*:*)+	# the GNU system+	echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`+	exit ;;+    *:GNU/*:*:*)+	# other systems with GNU libc and userland+	echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu+	exit ;;+    i*86:Minix:*:*)+	echo ${UNAME_MACHINE}-pc-minix+	exit ;;+    arm*:Linux:*:*)+	eval $set_cc_for_build+	if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \+	    | grep -q __ARM_EABI__+	then+	    echo ${UNAME_MACHINE}-unknown-linux-gnu+	else+	    echo ${UNAME_MACHINE}-unknown-linux-gnueabi+	fi+	exit ;;+    avr32*:Linux:*:*)+	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    cris:Linux:*:*)+	echo cris-axis-linux-gnu+	exit ;;+    crisv32:Linux:*:*)+	echo crisv32-axis-linux-gnu+	exit ;;+    frv:Linux:*:*)+    	echo frv-unknown-linux-gnu+	exit ;;+    ia64:Linux:*:*)+	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    m32r*:Linux:*:*)+	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    m68*:Linux:*:*)+	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    mips:Linux:*:*)+	eval $set_cc_for_build+	sed 's/^	//' << EOF >$dummy.c+	#undef CPU+	#undef mips+	#undef mipsel+	#if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)+	CPU=mipsel+	#else+	#if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)+	CPU=mips+	#else+	CPU=+	#endif+	#endif+EOF+	eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '+	    /^CPU/{+		s: ::g+		p+	    }'`"+	test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }+	;;+    mips64:Linux:*:*)+	eval $set_cc_for_build+	sed 's/^	//' << EOF >$dummy.c+	#undef CPU+	#undef mips64+	#undef mips64el+	#if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)+	CPU=mips64el+	#else+	#if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)+	CPU=mips64+	#else+	CPU=+	#endif+	#endif+EOF+	eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '+	    /^CPU/{+		s: ::g+		p+	    }'`"+	test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }+	;;+    or32:Linux:*:*)+	echo or32-unknown-linux-gnu+	exit ;;+    ppc:Linux:*:*)+	echo powerpc-unknown-linux-gnu+	exit ;;+    ppc64:Linux:*:*)+	echo powerpc64-unknown-linux-gnu+	exit ;;+    alpha:Linux:*:*)+	case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` 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 ld.so.1 >/dev/null+	if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi+	echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}+	exit ;;+    parisc:Linux:*:* | hppa:Linux:*:*)+	# Look for CPU level+	case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in+	  PA7*) echo hppa1.1-unknown-linux-gnu ;;+	  PA8*) echo hppa2.0-unknown-linux-gnu ;;+	  *)    echo hppa-unknown-linux-gnu ;;+	esac+	exit ;;+    parisc64:Linux:*:* | hppa64:Linux:*:*)+	echo hppa64-unknown-linux-gnu+	exit ;;+    s390:Linux:*:* | s390x:Linux:*:*)+	echo ${UNAME_MACHINE}-ibm-linux+	exit ;;+    sh64*:Linux:*:*)+    	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    sh*:Linux:*:*)+	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    sparc:Linux:*:* | sparc64:Linux:*:*)+	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    vax:Linux:*:*)+	echo ${UNAME_MACHINE}-dec-linux-gnu+	exit ;;+    x86_64:Linux:*:*)+	echo x86_64-unknown-linux-gnu+	exit ;;+    xtensa*:Linux:*:*)+    	echo ${UNAME_MACHINE}-unknown-linux-gnu+	exit ;;+    i*86:Linux:*:*)+	# The BFD linker knows what the default object file format is, so+	# first see if it will tell us. cd to the root directory to prevent+	# problems with other programs or directories called `ld' in the path.+	# Set LC_ALL=C to ensure ld outputs messages in English.+	ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \+			 | sed -ne '/supported targets:/!d+				    s/[ 	][ 	]*/ /g+				    s/.*supported targets: *//+				    s/ .*//+				    p'`+        case "$ld_supported_targets" in+	  elf32-i386)+		TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"+		;;+	  a.out-i386-linux)+		echo "${UNAME_MACHINE}-pc-linux-gnuaout"+		exit ;;+	  coff-i386)+		echo "${UNAME_MACHINE}-pc-linux-gnucoff"+		exit ;;+	  "")+		# Either a pre-BFD a.out linker (linux-gnuoldld) or+		# one that does not give us useful --help.+		echo "${UNAME_MACHINE}-pc-linux-gnuoldld"+		exit ;;+	esac+	# Determine whether the default compiler is a.out or elf+	eval $set_cc_for_build+	sed 's/^	//' << EOF >$dummy.c+	#include <features.h>+	#ifdef __ELF__+	# ifdef __GLIBC__+	#  if __GLIBC__ >= 2+	LIBC=gnu+	#  else+	LIBC=gnulibc1+	#  endif+	# else+	LIBC=gnulibc1+	# endif+	#else+	#if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC)+	LIBC=gnu+	#else+	LIBC=gnuaout+	#endif+	#endif+	#ifdef __dietlibc__+	LIBC=dietlibc+	#endif+EOF+	eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '+	    /^LIBC/{+		s: ::g+		p+	    }'`"+	test x"${LIBC}" != x && {+		echo "${UNAME_MACHINE}-pc-linux-${LIBC}"+		exit+	}+	test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; }+	;;+    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.+	echo i386-sequent-sysv4+	exit ;;+    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.+	echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}+	exit ;;+    i*86:OS/2:*:*)+	# If we were able to find `uname', then EMX Unix compatibility+	# is probably installed.+	echo ${UNAME_MACHINE}-pc-os2-emx+	exit ;;+    i*86:XTS-300:*:STOP)+	echo ${UNAME_MACHINE}-unknown-stop+	exit ;;+    i*86:atheos:*:*)+	echo ${UNAME_MACHINE}-unknown-atheos+	exit ;;+    i*86:syllable:*:*)+	echo ${UNAME_MACHINE}-pc-syllable+	exit ;;+    i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)+	echo i386-unknown-lynxos${UNAME_RELEASE}+	exit ;;+    i*86:*DOS:*:*)+	echo ${UNAME_MACHINE}-pc-msdosdjgpp+	exit ;;+    i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)+	UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`+	if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then+		echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL}+	else+		echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}+	fi+	exit ;;+    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+	echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}+	exit ;;+    i*86:*:3.2:*)+	if test -f /usr/options/cb.name; then+		UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`+		echo ${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+		echo ${UNAME_MACHINE}-pc-sco$UNAME_REL+	else+		echo ${UNAME_MACHINE}-pc-sysv32+	fi+	exit ;;+    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 i386.+	echo i386-pc-msdosdjgpp+        exit ;;+    Intel:Mach:3*:*)+	echo i386-pc-mach3+	exit ;;+    paragon:*:*:*)+	echo i860-intel-osf1+	exit ;;+    i860:*:4.*:*) # i860-SVR4+	if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then+	  echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4+	else # Add other i860-SVR4 vendors below as they are discovered.+	  echo i860-unknown-sysv${UNAME_RELEASE}  # Unknown i860-SVR4+	fi+	exit ;;+    mini*:CTIX:SYS*5:*)+	# "miniframe"+	echo m68010-convergent-sysv+	exit ;;+    mc68k:UNIX:SYSTEM5:3.51m)+	echo m68k-convergent-sysv+	exit ;;+    M680?0:D-NIX:5.3:*)+	echo m68k-diab-dnix+	exit ;;+    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; } ;;+    m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)+	echo m68k-unknown-lynxos${UNAME_RELEASE}+	exit ;;+    mc68030:UNIX_System_V:4.*:*)+	echo m68k-atari-sysv4+	exit ;;+    TSUNAMI:LynxOS:2.*:*)+	echo sparc-unknown-lynxos${UNAME_RELEASE}+	exit ;;+    rs6000:LynxOS:2.*:*)+	echo rs6000-unknown-lynxos${UNAME_RELEASE}+	exit ;;+    PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)+	echo powerpc-unknown-lynxos${UNAME_RELEASE}+	exit ;;+    SM[BE]S:UNIX_SV:*:*)+	echo mips-dde-sysv${UNAME_RELEASE}+	exit ;;+    RM*:ReliantUNIX-*:*:*)+	echo mips-sni-sysv4+	exit ;;+    RM*:SINIX-*:*:*)+	echo mips-sni-sysv4+	exit ;;+    *:SINIX-*:*:*)+	if uname -p 2>/dev/null >/dev/null ; then+		UNAME_MACHINE=`(uname -p) 2>/dev/null`+		echo ${UNAME_MACHINE}-sni-sysv4+	else+		echo ns32k-sni-sysv+	fi+	exit ;;+    PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort+                      # says <Richard.M.Bartel@ccMail.Census.GOV>+        echo i586-unisys-sysv4+        exit ;;+    *:UNIX_System_V:4*:FTX*)+	# From Gerald Hewes <hewes@openmarket.com>.+	# How about differentiating between stratus architectures? -djm+	echo hppa1.1-stratus-sysv4+	exit ;;+    *:*:*:FTX*)+	# From seanf@swdc.stratus.com.+	echo i860-stratus-sysv4+	exit ;;+    i*86:VOS:*:*)+	# From Paul.Green@stratus.com.+	echo ${UNAME_MACHINE}-stratus-vos+	exit ;;+    *:VOS:*:*)+	# From Paul.Green@stratus.com.+	echo hppa1.1-stratus-vos+	exit ;;+    mc68*:A/UX:*:*)+	echo m68k-apple-aux${UNAME_RELEASE}+	exit ;;+    news*:NEWS-OS:6*:*)+	echo mips-sony-newsos6+	exit ;;+    R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)+	if [ -d /usr/nec ]; then+	        echo mips-nec-sysv${UNAME_RELEASE}+	else+	        echo mips-unknown-sysv${UNAME_RELEASE}+	fi+        exit ;;+    BeBox:BeOS:*:*)	# BeOS running on hardware made by Be, PPC only.+	echo powerpc-be-beos+	exit ;;+    BeMac:BeOS:*:*)	# BeOS running on Mac or Mac clone, PPC only.+	echo powerpc-apple-beos+	exit ;;+    BePC:BeOS:*:*)	# BeOS running on Intel PC compatible.+	echo i586-pc-beos+	exit ;;+    SX-4:SUPER-UX:*:*)+	echo sx4-nec-superux${UNAME_RELEASE}+	exit ;;+    SX-5:SUPER-UX:*:*)+	echo sx5-nec-superux${UNAME_RELEASE}+	exit ;;+    SX-6:SUPER-UX:*:*)+	echo sx6-nec-superux${UNAME_RELEASE}+	exit ;;+    SX-7:SUPER-UX:*:*)+	echo sx7-nec-superux${UNAME_RELEASE}+	exit ;;+    SX-8:SUPER-UX:*:*)+	echo sx8-nec-superux${UNAME_RELEASE}+	exit ;;+    SX-8R:SUPER-UX:*:*)+	echo sx8r-nec-superux${UNAME_RELEASE}+	exit ;;+    Power*:Rhapsody:*:*)+	echo powerpc-apple-rhapsody${UNAME_RELEASE}+	exit ;;+    *:Rhapsody:*:*)+	echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}+	exit ;;+    *:Darwin:*:*)+	UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown+	case $UNAME_PROCESSOR in+	    unknown) UNAME_PROCESSOR=powerpc ;;+	esac+	echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}+	exit ;;+    *:procnto*:*:* | *:QNX:[0123456789]*:*)+	UNAME_PROCESSOR=`uname -p`+	if test "$UNAME_PROCESSOR" = "x86"; then+		UNAME_PROCESSOR=i386+		UNAME_MACHINE=pc+	fi+	echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}+	exit ;;+    *:QNX:*:4*)+	echo i386-pc-qnx+	exit ;;+    NSE-?:NONSTOP_KERNEL:*:*)+	echo nse-tandem-nsk${UNAME_RELEASE}+	exit ;;+    NSR-?:NONSTOP_KERNEL:*:*)+	echo nsr-tandem-nsk${UNAME_RELEASE}+	exit ;;+    *:NonStop-UX:*:*)+	echo mips-compaq-nonstopux+	exit ;;+    BS2000:POSIX*:*:*)+	echo bs2000-siemens-sysv+	exit ;;+    DS/*:UNIX_System_V:*:*)+	echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}+	exit ;;+    *: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+	else+	    UNAME_MACHINE="$cputype"+	fi+	echo ${UNAME_MACHINE}-unknown-plan9+	exit ;;+    *:TOPS-10:*:*)+	echo pdp10-unknown-tops10+	exit ;;+    *:TENEX:*:*)+	echo pdp10-unknown-tenex+	exit ;;+    KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)+	echo pdp10-dec-tops20+	exit ;;+    XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)+	echo pdp10-xkl-tops20+	exit ;;+    *:TOPS-20:*:*)+	echo pdp10-unknown-tops20+	exit ;;+    *:ITS:*:*)+	echo pdp10-unknown-its+	exit ;;+    SEI:*:*:SEIUX)+        echo mips-sei-seiux${UNAME_RELEASE}+	exit ;;+    *:DragonFly:*:*)+	echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`+	exit ;;+    *:*VMS:*:*)+    	UNAME_MACHINE=`(uname -p) 2>/dev/null`+	case "${UNAME_MACHINE}" in+	    A*) echo alpha-dec-vms ; exit ;;+	    I*) echo ia64-dec-vms ; exit ;;+	    V*) echo vax-dec-vms ; exit ;;+	esac ;;+    *:XENIX:*:SysV)+	echo i386-pc-xenix+	exit ;;+    i*86:skyos:*:*)+	echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'+	exit ;;+    i*86:rdos:*:*)+	echo ${UNAME_MACHINE}-pc-rdos+	exit ;;+esac++#echo '(No uname command or uname output not recognized.)' 1>&2+#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2++eval $set_cc_for_build+cat >$dummy.c <<EOF+#ifdef _SEQUENT_+# include <sys/types.h>+# include <sys/utsname.h>+#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 (__arm) && defined (__acorn) && defined (__unix)+  printf ("arm-acorn-riscix\n"); exit (0);+#endif++#if defined (hp300) && !defined (hpux)+  printf ("m68k-hp-bsd\n"); exit (0);+#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+    printf ("vax-dec-ultrix\n"); exit (0);+# 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; }++# Convex versions that predate uname can use getsysinfo(1)++if [ -x /usr/convex/getsysinfo ]+then+    case `getsysinfo -f cpu_type` in+    c1*)+	echo c1-convex-bsd+	exit ;;+    c2*)+	if getsysinfo -f scalar_acc+	then echo c32-convex-bsd+	else echo c2-convex-bsd+	fi+	exit ;;+    c34*)+	echo c34-convex-bsd+	exit ;;+    c38*)+	echo c38-convex-bsd+	exit ;;+    c4*)+	echo c4-convex-bsd+	exit ;;+    esac+fi++cat >&2 <<EOF+$0: unable to guess system type++This script, last modified $timestamp, has failed to recognize+the operating system you are using. It is advised that you+download the most up to date version of the config scripts from++  http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD+and+  http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD++If the version you run ($0) is already up to date, please+send the following data and any information you think might be+pertinent to <config-patches@gnu.org> in order to provide the needed+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++exit 1++# Local variables:+# eval: (add-hook 'write-file-hooks 'time-stamp)+# time-stamp-start: "timestamp='"+# time-stamp-format: "%:y-%02m-%02d"+# time-stamp-end: "'"+# End:
+ config.sub view
@@ -0,0 +1,1658 @@+#! /bin/sh+# Configuration validation subroutine script.+#   Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,+#   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008+#   Free Software Foundation, Inc.++timestamp='2008-01-16'++# This file is (in principle) common to ALL GNU software.+# The presence of a machine in this file suggests that SOME GNU software+# can handle that machine.  It does not imply ALL GNU software can.+#+# 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 2 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, write to the Free Software+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA+# 02110-1301, USA.+#+# 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.+++# Please send patches to <config-patches@gnu.org>.  Submit a context+# diff and a properly formatted ChangeLog entry.+#+# 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.++# 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.++me=`echo "$0" | sed -e 's,.*/,,'`++usage="\+Usage: $0 [OPTION] CPU-MFR-OPSYS+       $0 [OPTION] ALIAS++Canonicalize a configuration name.++Operation modes:+  -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 (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,+2002, 2003, 2004, 2005, 2006, 2007, 2008 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"+       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++# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).+# Here we must recognize all the valid KERNEL-OS combinations.+maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`+case $maybe_os in+  nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \+  uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \+  storm-chaos* | os2-emx* | rtmk-nova*)+    os=-$maybe_os+    basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`+    ;;+  *)+    basic_machine=`echo $1 | sed 's/-[^-]*$//'`+    if [ $basic_machine != $1 ]+    then os=`echo $1 | sed 's/.*-/-/'`+    else os=; fi+    ;;+esac++### Let's recognize common machines as not being operating systems so+### that things like config.sub decstation-3100 work.  We also+### recognize some manufacturers as not being operating systems, so we+### can provide default operating systems below.+case $os in+	-sun*os*)+		# Prevent following clause from handling this invalid input.+		;;+	-dec* | -mips* | -sequent* | -encore* | -pc532* | -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)+		os=+		basic_machine=$1+		;;+	-sim | -cisco | -oki | -wec | -winbond)+		os=+		basic_machine=$1+		;;+	-scout)+		;;+	-wrs)+		os=-vxworks+		basic_machine=$1+		;;+	-chorusos*)+		os=-chorusos+		basic_machine=$1+		;;+ 	-chorusrdb)+ 		os=-chorusrdb+		basic_machine=$1+ 		;;+	-hiux*)+		os=-hiuxwe2+		;;+	-sco6)+		os=-sco5v6+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-sco5)+		os=-sco3.2v5+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-sco4)+		os=-sco3.2v4+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-sco3.2.[4-9]*)+		os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-sco3.2v[4-9]*)+		# Don't forget version if it is 3.2v4 or newer.+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-sco5v6*)+		# Don't forget version if it is 3.2v4 or newer.+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-sco*)+		os=-sco3.2v2+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-udk*)+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-isc)+		os=-isc2.2+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-clix*)+		basic_machine=clipper-intergraph+		;;+	-isc*)+		basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`+		;;+	-lynx*)+		os=-lynxos+		;;+	-ptx*)+		basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`+		;;+	-windowsnt*)+		os=`echo $os | sed -e 's/windowsnt/winnt/'`+		;;+	-psos*)+		os=-psos+		;;+	-mint | -mint[0-9]*)+		basic_machine=m68k-atari+		os=-mint+		;;+esac++# Decode aliases for certain CPU-COMPANY combinations.+case $basic_machine in+	# Recognize the basic CPU types without company name.+	# Some are omitted here because they have special meanings below.+	1750a | 580 \+	| a29k \+	| alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \+	| alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \+	| am33_2.0 \+	| arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \+	| bfin \+	| c4x | clipper \+	| d10v | d30v | dlx | dsp16xx \+	| fido | fr30 | frv \+	| h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \+	| i370 | i860 | i960 | ia64 \+	| ip2k | iq2000 \+	| m32c | m32r | m32rle | m68000 | m68k | m88k \+	| maxq | mb | microblaze | mcore | mep \+	| mips | mipsbe | mipseb | mipsel | mipsle \+	| mips16 \+	| mips64 | mips64el \+	| mips64vr | mips64vrel \+	| mips64orion | mips64orionel \+	| mips64vr4100 | mips64vr4100el \+	| mips64vr4300 | mips64vr4300el \+	| mips64vr5000 | mips64vr5000el \+	| mips64vr5900 | mips64vr5900el \+	| mipsisa32 | mipsisa32el \+	| mipsisa32r2 | mipsisa32r2el \+	| mipsisa64 | mipsisa64el \+	| mipsisa64r2 | mipsisa64r2el \+	| mipsisa64sb1 | mipsisa64sb1el \+	| mipsisa64sr71k | mipsisa64sr71kel \+	| mipstx39 | mipstx39el \+	| mn10200 | mn10300 \+	| mt \+	| msp430 \+	| nios | nios2 \+	| ns16k | ns32k \+	| or32 \+	| pdp10 | pdp11 | pj | pjl \+	| powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \+	| pyramid \+	| score \+	| sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \+	| sh64 | sh64le \+	| sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \+	| sparcv8 | sparcv9 | sparcv9b | sparcv9v \+	| spu | strongarm \+	| tahoe | thumb | tic4x | tic80 | tron \+	| v850 | v850e \+	| we32k \+	| x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \+	| z8k)+		basic_machine=$basic_machine-unknown+		;;+	m6811 | m68hc11 | m6812 | m68hc12)+		# Motorola 68HC11/12.+		basic_machine=$basic_machine-unknown+		os=-none+		;;+	m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)+		;;+	ms1)+		basic_machine=mt-unknown+		;;++	# 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)+	  basic_machine=$basic_machine-pc+	  ;;+	# Object if more than one company name word.+	*-*-*)+		echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2+		exit 1+		;;+	# Recognize the basic CPU types with company name.+	580-* \+	| a29k-* \+	| alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \+	| alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \+	| alphapca5[67]-* | alpha64pca5[67]-* | arc-* \+	| arm-*  | armbe-* | armle-* | armeb-* | armv*-* \+	| avr-* | avr32-* \+	| bfin-* | bs2000-* \+	| c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \+	| clipper-* | craynv-* | cydra-* \+	| d10v-* | d30v-* | dlx-* \+	| elxsi-* \+	| f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \+	| h8300-* | h8500-* \+	| hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \+	| i*86-* | i860-* | i960-* | ia64-* \+	| ip2k-* | iq2000-* \+	| m32c-* | m32r-* | m32rle-* \+	| m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \+	| m88110-* | m88k-* | maxq-* | mcore-* \+	| mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \+	| mips16-* \+	| mips64-* | mips64el-* \+	| mips64vr-* | mips64vrel-* \+	| mips64orion-* | mips64orionel-* \+	| mips64vr4100-* | mips64vr4100el-* \+	| mips64vr4300-* | mips64vr4300el-* \+	| mips64vr5000-* | mips64vr5000el-* \+	| mips64vr5900-* | mips64vr5900el-* \+	| mipsisa32-* | mipsisa32el-* \+	| mipsisa32r2-* | mipsisa32r2el-* \+	| mipsisa64-* | mipsisa64el-* \+	| mipsisa64r2-* | mipsisa64r2el-* \+	| mipsisa64sb1-* | mipsisa64sb1el-* \+	| mipsisa64sr71k-* | mipsisa64sr71kel-* \+	| mipstx39-* | mipstx39el-* \+	| mmix-* \+	| mt-* \+	| msp430-* \+	| nios-* | nios2-* \+	| none-* | np1-* | ns16k-* | ns32k-* \+	| orion-* \+	| pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \+	| powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \+	| pyramid-* \+	| romp-* | rs6000-* \+	| sh-* | sh[1234]-* | sh[24]a-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \+	| shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \+	| sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \+	| sparclite-* \+	| sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \+	| tahoe-* | thumb-* \+	| tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \+	| tron-* \+	| v850-* | v850e-* | vax-* \+	| we32k-* \+	| x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \+	| xstormy16-* | xtensa*-* \+	| ymp-* \+	| z8k-*)+		;;+	# Recognize the basic CPU types without company name, with glob match.+	xtensa*)+		basic_machine=$basic_machine-unknown+		;;+	# Recognize the various machine names and aliases which stand+	# for a CPU type and a company and sometimes even an OS.+	386bsd)+		basic_machine=i386-unknown+		os=-bsd+		;;+	3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)+		basic_machine=m68000-att+		;;+	3b*)+		basic_machine=we32k-att+		;;+	a29khif)+		basic_machine=a29k-amd+		os=-udi+		;;+    	abacus)+		basic_machine=abacus-unknown+		;;+	adobe68k)+		basic_machine=m68010-adobe+		os=-scout+		;;+	alliant | fx80)+		basic_machine=fx80-alliant+		;;+	altos | altos3068)+		basic_machine=m68k-altos+		;;+	am29k)+		basic_machine=a29k-none+		os=-bsd+		;;+	amd64)+		basic_machine=x86_64-pc+		;;+	amd64-*)+		basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	amdahl)+		basic_machine=580-amdahl+		os=-sysv+		;;+	amiga | amiga-*)+		basic_machine=m68k-unknown+		;;+	amigaos | amigados)+		basic_machine=m68k-unknown+		os=-amigaos+		;;+	amigaunix | amix)+		basic_machine=m68k-unknown+		os=-sysv4+		;;+	apollo68)+		basic_machine=m68k-apollo+		os=-sysv+		;;+	apollo68bsd)+		basic_machine=m68k-apollo+		os=-bsd+		;;+	aux)+		basic_machine=m68k-apple+		os=-aux+		;;+	balance)+		basic_machine=ns32k-sequent+		os=-dynix+		;;+	blackfin)+		basic_machine=bfin-unknown+		os=-linux+		;;+	blackfin-*)+		basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'`+		os=-linux+		;;+	c90)+		basic_machine=c90-cray+		os=-unicos+		;;+	convex-c1)+		basic_machine=c1-convex+		os=-bsd+		;;+	convex-c2)+		basic_machine=c2-convex+		os=-bsd+		;;+	convex-c32)+		basic_machine=c32-convex+		os=-bsd+		;;+	convex-c34)+		basic_machine=c34-convex+		os=-bsd+		;;+	convex-c38)+		basic_machine=c38-convex+		os=-bsd+		;;+	cray | j90)+		basic_machine=j90-cray+		os=-unicos+		;;+	craynv)+		basic_machine=craynv-cray+		os=-unicosmp+		;;+	cr16)+		basic_machine=cr16-unknown+		os=-elf+		;;+	crds | unos)+		basic_machine=m68k-crds+		;;+	crisv32 | crisv32-* | etraxfs*)+		basic_machine=crisv32-axis+		;;+	cris | cris-* | etrax*)+		basic_machine=cris-axis+		;;+	crx)+		basic_machine=crx-unknown+		os=-elf+		;;+	da30 | da30-*)+		basic_machine=m68k-da30+		;;+	decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)+		basic_machine=mips-dec+		;;+	decsystem10* | dec10*)+		basic_machine=pdp10-dec+		os=-tops10+		;;+	decsystem20* | dec20*)+		basic_machine=pdp10-dec+		os=-tops20+		;;+	delta | 3300 | motorola-3300 | motorola-delta \+	      | 3300-motorola | delta-motorola)+		basic_machine=m68k-motorola+		;;+	delta88)+		basic_machine=m88k-motorola+		os=-sysv3+		;;+	djgpp)+		basic_machine=i586-pc+		os=-msdosdjgpp+		;;+	dpx20 | dpx20-*)+		basic_machine=rs6000-bull+		os=-bosx+		;;+	dpx2* | dpx2*-bull)+		basic_machine=m68k-bull+		os=-sysv3+		;;+	ebmon29k)+		basic_machine=a29k-amd+		os=-ebmon+		;;+	elxsi)+		basic_machine=elxsi-elxsi+		os=-bsd+		;;+	encore | umax | mmax)+		basic_machine=ns32k-encore+		;;+	es1800 | OSE68k | ose68k | ose | OSE)+		basic_machine=m68k-ericsson+		os=-ose+		;;+	fx2800)+		basic_machine=i860-alliant+		;;+	genix)+		basic_machine=ns32k-ns+		;;+	gmicro)+		basic_machine=tron-gmicro+		os=-sysv+		;;+	go32)+		basic_machine=i386-pc+		os=-go32+		;;+	h3050r* | hiux*)+		basic_machine=hppa1.1-hitachi+		os=-hiuxwe2+		;;+	h8300hms)+		basic_machine=h8300-hitachi+		os=-hms+		;;+	h8300xray)+		basic_machine=h8300-hitachi+		os=-xray+		;;+	h8500hms)+		basic_machine=h8500-hitachi+		os=-hms+		;;+	harris)+		basic_machine=m88k-harris+		os=-sysv3+		;;+	hp300-*)+		basic_machine=m68k-hp+		;;+	hp300bsd)+		basic_machine=m68k-hp+		os=-bsd+		;;+	hp300hpux)+		basic_machine=m68k-hp+		os=-hpux+		;;+	hp3k9[0-9][0-9] | hp9[0-9][0-9])+		basic_machine=hppa1.0-hp+		;;+	hp9k2[0-9][0-9] | hp9k31[0-9])+		basic_machine=m68000-hp+		;;+	hp9k3[2-9][0-9])+		basic_machine=m68k-hp+		;;+	hp9k6[0-9][0-9] | hp6[0-9][0-9])+		basic_machine=hppa1.0-hp+		;;+	hp9k7[0-79][0-9] | hp7[0-79][0-9])+		basic_machine=hppa1.1-hp+		;;+	hp9k78[0-9] | hp78[0-9])+		# FIXME: really hppa2.0-hp+		basic_machine=hppa1.1-hp+		;;+	hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893)+		# FIXME: really hppa2.0-hp+		basic_machine=hppa1.1-hp+		;;+	hp9k8[0-9][13679] | hp8[0-9][13679])+		basic_machine=hppa1.1-hp+		;;+	hp9k8[0-9][0-9] | hp8[0-9][0-9])+		basic_machine=hppa1.0-hp+		;;+	hppa-next)+		os=-nextstep3+		;;+	hppaosf)+		basic_machine=hppa1.1-hp+		os=-osf+		;;+	hppro)+		basic_machine=hppa1.1-hp+		os=-proelf+		;;+	i370-ibm* | ibm*)+		basic_machine=i370-ibm+		;;+# I'm not sure what "Sysv32" means.  Should this be sysv3.2?+	i*86v32)+		basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+		os=-sysv32+		;;+	i*86v4*)+		basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+		os=-sysv4+		;;+	i*86v)+		basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+		os=-sysv+		;;+	i*86sol2)+		basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`+		os=-solaris2+		;;+	i386mach)+		basic_machine=i386-mach+		os=-mach+		;;+	i386-vsta | vsta)+		basic_machine=i386-unknown+		os=-vsta+		;;+	iris | iris4d)+		basic_machine=mips-sgi+		case $os in+		    -irix*)+			;;+		    *)+			os=-irix4+			;;+		esac+		;;+	isi68 | isi)+		basic_machine=m68k-isi+		os=-sysv+		;;+	m68knommu)+		basic_machine=m68k-unknown+		os=-linux+		;;+	m68knommu-*)+		basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'`+		os=-linux+		;;+	m88k-omron*)+		basic_machine=m88k-omron+		;;+	magnum | m3230)+		basic_machine=mips-mips+		os=-sysv+		;;+	merlin)+		basic_machine=ns32k-utek+		os=-sysv+		;;+	mingw32)+		basic_machine=i386-pc+		os=-mingw32+		;;+	mingw32ce)+		basic_machine=arm-unknown+		os=-mingw32ce+		;;+	miniframe)+		basic_machine=m68000-convergent+		;;+	*mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*)+		basic_machine=m68k-atari+		os=-mint+		;;+	mips3*-*)+		basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`+		;;+	mips3*)+		basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown+		;;+	monitor)+		basic_machine=m68k-rom68k+		os=-coff+		;;+	morphos)+		basic_machine=powerpc-unknown+		os=-morphos+		;;+	msdos)+		basic_machine=i386-pc+		os=-msdos+		;;+	ms1-*)+		basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`+		;;+	mvs)+		basic_machine=i370-ibm+		os=-mvs+		;;+	ncr3000)+		basic_machine=i486-ncr+		os=-sysv4+		;;+	netbsd386)+		basic_machine=i386-unknown+		os=-netbsd+		;;+	netwinder)+		basic_machine=armv4l-rebel+		os=-linux+		;;+	news | news700 | news800 | news900)+		basic_machine=m68k-sony+		os=-newsos+		;;+	news1000)+		basic_machine=m68030-sony+		os=-newsos+		;;+	news-3600 | risc-news)+		basic_machine=mips-sony+		os=-newsos+		;;+	necv70)+		basic_machine=v70-nec+		os=-sysv+		;;+	next | m*-next )+		basic_machine=m68k-next+		case $os in+		    -nextstep* )+			;;+		    -ns2*)+		      os=-nextstep2+			;;+		    *)+		      os=-nextstep3+			;;+		esac+		;;+	nh3000)+		basic_machine=m68k-harris+		os=-cxux+		;;+	nh[45]000)+		basic_machine=m88k-harris+		os=-cxux+		;;+	nindy960)+		basic_machine=i960-intel+		os=-nindy+		;;+	mon960)+		basic_machine=i960-intel+		os=-mon960+		;;+	nonstopux)+		basic_machine=mips-compaq+		os=-nonstopux+		;;+	np1)+		basic_machine=np1-gould+		;;+	nsr-tandem)+		basic_machine=nsr-tandem+		;;+	op50n-* | op60c-*)+		basic_machine=hppa1.1-oki+		os=-proelf+		;;+	openrisc | openrisc-*)+		basic_machine=or32-unknown+		;;+	os400)+		basic_machine=powerpc-ibm+		os=-os400+		;;+	OSE68000 | ose68000)+		basic_machine=m68000-ericsson+		os=-ose+		;;+	os68k)+		basic_machine=m68k-none+		os=-os68k+		;;+	pa-hitachi)+		basic_machine=hppa1.1-hitachi+		os=-hiuxwe2+		;;+	paragon)+		basic_machine=i860-intel+		os=-osf+		;;+	parisc)+		basic_machine=hppa-unknown+		os=-linux+		;;+	parisc-*)+		basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'`+		os=-linux+		;;+	pbd)+		basic_machine=sparc-tti+		;;+	pbb)+		basic_machine=m68k-tti+		;;+	pc532 | pc532-*)+		basic_machine=ns32k-pc532+		;;+	pc98)+		basic_machine=i386-pc+		;;+	pc98-*)+		basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	pentium | p5 | k5 | k6 | nexgen | viac3)+		basic_machine=i586-pc+		;;+	pentiumpro | p6 | 6x86 | athlon | athlon_*)+		basic_machine=i686-pc+		;;+	pentiumii | pentium2 | pentiumiii | pentium3)+		basic_machine=i686-pc+		;;+	pentium4)+		basic_machine=i786-pc+		;;+	pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)+		basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	pentiumpro-* | p6-* | 6x86-* | athlon-*)+		basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)+		basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	pentium4-*)+		basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	pn)+		basic_machine=pn-gould+		;;+	power)	basic_machine=power-ibm+		;;+	ppc)	basic_machine=powerpc-unknown+		;;+	ppc-*)	basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	ppcle | powerpclittle | ppc-le | powerpc-little)+		basic_machine=powerpcle-unknown+		;;+	ppcle-* | powerpclittle-*)+		basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	ppc64)	basic_machine=powerpc64-unknown+		;;+	ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	ppc64le | powerpc64little | ppc64-le | powerpc64-little)+		basic_machine=powerpc64le-unknown+		;;+	ppc64le-* | powerpc64little-*)+		basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'`+		;;+	ps2)+		basic_machine=i386-ibm+		;;+	pw32)+		basic_machine=i586-unknown+		os=-pw32+		;;+	rdos)+		basic_machine=i386-pc+		os=-rdos+		;;+	rom68k)+		basic_machine=m68k-rom68k+		os=-coff+		;;+	rm[46]00)+		basic_machine=mips-siemens+		;;+	rtpc | rtpc-*)+		basic_machine=romp-ibm+		;;+	s390 | s390-*)+		basic_machine=s390-ibm+		;;+	s390x | s390x-*)+		basic_machine=s390x-ibm+		;;+	sa29200)+		basic_machine=a29k-amd+		os=-udi+		;;+	sb1)+		basic_machine=mipsisa64sb1-unknown+		;;+	sb1el)+		basic_machine=mipsisa64sb1el-unknown+		;;+	sde)+		basic_machine=mipsisa32-sde+		os=-elf+		;;+	sei)+		basic_machine=mips-sei+		os=-seiux+		;;+	sequent)+		basic_machine=i386-sequent+		;;+	sh)+		basic_machine=sh-hitachi+		os=-hms+		;;+	sh5el)+		basic_machine=sh5le-unknown+		;;+	sh64)+		basic_machine=sh64-unknown+		;;+	sparclite-wrs | simso-wrs)+		basic_machine=sparclite-wrs+		os=-vxworks+		;;+	sps7)+		basic_machine=m68k-bull+		os=-sysv2+		;;+	spur)+		basic_machine=spur-unknown+		;;+	st2000)+		basic_machine=m68k-tandem+		;;+	stratus)+		basic_machine=i860-stratus+		os=-sysv4+		;;+	sun2)+		basic_machine=m68000-sun+		;;+	sun2os3)+		basic_machine=m68000-sun+		os=-sunos3+		;;+	sun2os4)+		basic_machine=m68000-sun+		os=-sunos4+		;;+	sun3os3)+		basic_machine=m68k-sun+		os=-sunos3+		;;+	sun3os4)+		basic_machine=m68k-sun+		os=-sunos4+		;;+	sun4os3)+		basic_machine=sparc-sun+		os=-sunos3+		;;+	sun4os4)+		basic_machine=sparc-sun+		os=-sunos4+		;;+	sun4sol2)+		basic_machine=sparc-sun+		os=-solaris2+		;;+	sun3 | sun3-*)+		basic_machine=m68k-sun+		;;+	sun4)+		basic_machine=sparc-sun+		;;+	sun386 | sun386i | roadrunner)+		basic_machine=i386-sun+		;;+	sv1)+		basic_machine=sv1-cray+		os=-unicos+		;;+	symmetry)+		basic_machine=i386-sequent+		os=-dynix+		;;+	t3e)+		basic_machine=alphaev5-cray+		os=-unicos+		;;+	t90)+		basic_machine=t90-cray+		os=-unicos+		;;+	tic54x | c54x*)+		basic_machine=tic54x-unknown+		os=-coff+		;;+	tic55x | c55x*)+		basic_machine=tic55x-unknown+		os=-coff+		;;+	tic6x | c6x*)+		basic_machine=tic6x-unknown+		os=-coff+		;;+	tile*)+		basic_machine=tile-unknown+		os=-linux-gnu+		;;+	tx39)+		basic_machine=mipstx39-unknown+		;;+	tx39el)+		basic_machine=mipstx39el-unknown+		;;+	toad1)+		basic_machine=pdp10-xkl+		os=-tops20+		;;+	tower | tower-32)+		basic_machine=m68k-ncr+		;;+	tpf)+		basic_machine=s390x-ibm+		os=-tpf+		;;+	udi29k)+		basic_machine=a29k-amd+		os=-udi+		;;+	ultra3)+		basic_machine=a29k-nyu+		os=-sym1+		;;+	v810 | necv810)+		basic_machine=v810-nec+		os=-none+		;;+	vaxv)+		basic_machine=vax-dec+		os=-sysv+		;;+	vms)+		basic_machine=vax-dec+		os=-vms+		;;+	vpp*|vx|vx-*)+		basic_machine=f301-fujitsu+		;;+	vxworks960)+		basic_machine=i960-wrs+		os=-vxworks+		;;+	vxworks68)+		basic_machine=m68k-wrs+		os=-vxworks+		;;+	vxworks29k)+		basic_machine=a29k-wrs+		os=-vxworks+		;;+	w65*)+		basic_machine=w65-wdc+		os=-none+		;;+	w89k-*)+		basic_machine=hppa1.1-winbond+		os=-proelf+		;;+	xbox)+		basic_machine=i686-pc+		os=-mingw32+		;;+	xps | xps100)+		basic_machine=xps100-honeywell+		;;+	ymp)+		basic_machine=ymp-cray+		os=-unicos+		;;+	z8k-*-coff)+		basic_machine=z8k-unknown+		os=-sim+		;;+	none)+		basic_machine=none-none+		os=-none+		;;++# 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)+		basic_machine=hppa1.1-winbond+		;;+	op50n)+		basic_machine=hppa1.1-oki+		;;+	op60c)+		basic_machine=hppa1.1-oki+		;;+	romp)+		basic_machine=romp-ibm+		;;+	mmix)+		basic_machine=mmix-knuth+		;;+	rs6000)+		basic_machine=rs6000-ibm+		;;+	vax)+		basic_machine=vax-dec+		;;+	pdp10)+		# there are many clones, so DEC is not a safe bet+		basic_machine=pdp10-unknown+		;;+	pdp11)+		basic_machine=pdp11-dec+		;;+	we32k)+		basic_machine=we32k-att+		;;+	sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele)+		basic_machine=sh-unknown+		;;+	sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)+		basic_machine=sparc-sun+		;;+	cydra)+		basic_machine=cydra-cydrome+		;;+	orion)+		basic_machine=orion-highlevel+		;;+	orion105)+		basic_machine=clipper-highlevel+		;;+	mac | mpw | mac-mpw)+		basic_machine=m68k-apple+		;;+	pmac | pmac-mpw)+		basic_machine=powerpc-apple+		;;+	*-unknown)+		# Make sure to match an already-canonicalized machine name.+		;;+	*)+		echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2+		exit 1+		;;+esac++# Here we canonicalize certain aliases for manufacturers.+case $basic_machine in+	*-digital*)+		basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`+		;;+	*-commodore*)+		basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`+		;;+	*)+		;;+esac++# Decode manufacturer-specific aliases for certain operating systems.++if [ x"$os" != x"" ]+then+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.+	-solaris1 | -solaris1.*)+		os=`echo $os | sed -e 's|solaris1|sunos4|'`+		;;+	-solaris)+		os=-solaris2+		;;+	-svr4*)+		os=-sysv4+		;;+	-unixware*)+		os=-sysv4.2uw+		;;+	-gnu/linux*)+		os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`+		;;+	# First accept the basic system types.+	# The portable systems comes first.+	# Each alternative MUST END IN A *, to match a version number.+	# -sysv* is not here because it comes later, after sysvr4.+	-gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \+	      | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\+	      | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \+	      | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \+	      | -aos* \+	      | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \+	      | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \+	      | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \+	      | -openbsd* | -solidbsd* \+	      | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \+	      | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \+	      | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \+	      | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \+	      | -chorusos* | -chorusrdb* \+	      | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \+	      | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \+	      | -uxpv* | -beos* | -mpeix* | -udk* \+	      | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \+	      | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \+	      | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \+	      | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \+	      | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \+	      | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \+	      | -skyos* | -haiku* | -rdos* | -toppers* | -drops*)+	# Remember, each alternative MUST END IN *, to match a version number.+		;;+	-qnx*)+		case $basic_machine in+		    x86-* | i*86-*)+			;;+		    *)+			os=-nto$os+			;;+		esac+		;;+	-nto-qnx*)+		;;+	-nto*)+		os=`echo $os | sed -e 's|nto|nto-qnx|'`+		;;+	-sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \+	      | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \+	      | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)+		;;+	-mac*)+		os=`echo $os | sed -e 's|mac|macos|'`+		;;+	-linux-dietlibc)+		os=-linux-dietlibc+		;;+	-linux*)+		os=`echo $os | sed -e 's|linux|linux-gnu|'`+		;;+	-sunos5*)+		os=`echo $os | sed -e 's|sunos5|solaris2|'`+		;;+	-sunos6*)+		os=`echo $os | sed -e 's|sunos6|solaris3|'`+		;;+	-opened*)+		os=-openedition+		;;+        -os400*)+		os=-os400+		;;+	-wince*)+		os=-wince+		;;+	-osfrose*)+		os=-osfrose+		;;+	-osf*)+		os=-osf+		;;+	-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+		;;+	-nsk*)+		os=-nsk+		;;+	# 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+		;;+	# This must come after -sysvr4.+	-sysv*)+		;;+	-ose*)+		os=-ose+		;;+	-es1800*)+		os=-ose+		;;+	-xenix)+		os=-xenix+		;;+	-*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*)+		os=-mint+		;;+	-aros*)+		os=-aros+		;;+	-kaos*)+		os=-kaos+		;;+	-zvmoe)+		os=-zvmoe+		;;+	-none)+		;;+	*)+		# Get rid of the `-' at the beginning of $os.+		os=`echo $os | sed 's/[^-]*-//'`+		echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2+		exit 1+		;;+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.++case $basic_machine in+        score-*)+		os=-elf+		;;+        spu-*)+		os=-elf+		;;+	*-acorn)+		os=-riscix1.2+		;;+	arm*-rebel)+		os=-linux+		;;+	arm*-semi)+		os=-aout+		;;+        c4x-* | tic4x-*)+        	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+		# This also exists in the configure program, but was not the+		# default.+		# os=-sunos4+		;;+	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+		;;+	*-be)+		os=-beos+		;;+	*-haiku)+		os=-haiku+		;;+	*-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+		;;+	*-next)+		os=-nextstep3+		;;+	*-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+		;;+	*)+		os=-none+		;;+esac+fi++# Here we handle the case where we know the os, and the CPU type, but not the+# manufacturer.  We pick the logical manufacturer.+vendor=unknown+case $basic_machine in+	*-unknown)+		case $os in+			-riscix*)+				vendor=acorn+				;;+			-sunos*)+				vendor=sun+				;;+			-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+				;;+			-mvs* | -opened*)+				vendor=ibm+				;;+			-os400*)+				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+		basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`+		;;+esac++echo $basic_machine$os+exit++# Local variables:+# eval: (add-hook 'write-file-hooks 'time-stamp)+# time-stamp-start: "timestamp='"+# time-stamp-format: "%:y-%02m-%02d"+# time-stamp-end: "'"+# End:
+ configure view
@@ -0,0 +1,12413 @@+#! /bin/sh+# Guess values for system-dependent variables and create Makefiles.+# Generated by GNU Autoconf 2.61 for Haskell base package 1.0.+#+# Report bugs to <libraries@haskell.org>.+#+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,+# 2002, 2003, 2004, 2005, 2006 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+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+  emulate sh+  NULLCMD=:+  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+  # is contrary to our usage.  Disable this feature.+  alias -g '${1+"$@"}'='"$@"'+  setopt NO_GLOB_SUBST+else+  case `(set -o) 2>/dev/null` in+  *posix*) set -o posix ;;+esac++fi+++++# PATH needs CR+# 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++# The user is always right.+if test "${PATH_SEPARATOR+set}" != set; then+  echo "#! /bin/sh" >conf$$.sh+  echo  "exit 0"   >>conf$$.sh+  chmod +x conf$$.sh+  if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then+    PATH_SEPARATOR=';'+  else+    PATH_SEPARATOR=:+  fi+  rm -f conf$$.sh+fi++# Support unset when possible.+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then+  as_unset=unset+else+  as_unset=false+fi+++# IFS+# We need space, tab and new line, in precisely that order.  Quoting is+# there to prevent editors from complaining about space-tab.+# (If _AS_PATH_WALK were called with IFS unset, it would disable word+# splitting by setting IFS to empty value.)+as_nl='+'+IFS=" ""	$as_nl"++# Find who we are.  Look in the path if we contain no directory separator.+case $0 in+  *[\\/]* ) as_myself=$0 ;;+  *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+  IFS=$as_save_IFS+  test -z "$as_dir" && as_dir=.+  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+  echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2+  { (exit 1); exit 1; }+fi++# Work around bugs in pre-3.0 UWIN ksh.+for as_var in ENV MAIL MAILPATH+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+done+PS1='$ '+PS2='> '+PS4='+ '++# NLS nuisances.+for as_var in \+  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \+  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \+  LC_TELEPHONE LC_TIME+do+  if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then+    eval $as_var=C; export $as_var+  else+    ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+  fi+done++# Required to use basename.+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+++# Name of the executable.+as_me=`$as_basename -- "$0" ||+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \+	 X"$0" : 'X\(//\)$' \| \+	 X"$0" : 'X\(/\)' \| . 2>/dev/null ||+echo X/"$0" |+    sed '/^.*\/\([^/][^/]*\)\/*$/{+	    s//\1/+	    q+	  }+	  /^X\/\(\/\/\)$/{+	    s//\1/+	    q+	  }+	  /^X\/\(\/\).*/{+	    s//\1/+	    q+	  }+	  s/.*/./; q'`++# CDPATH.+$as_unset CDPATH+++if test "x$CONFIG_SHELL" = x; then+  if (eval ":") 2>/dev/null; then+  as_have_required=yes+else+  as_have_required=no+fi++  if test $as_have_required = yes && 	 (eval ":+(as_func_return () {+  (exit \$1)+}+as_func_success () {+  as_func_return 0+}+as_func_failure () {+  as_func_return 1+}+as_func_ret_success () {+  return 0+}+as_func_ret_failure () {+  return 1+}++exitcode=0+if as_func_success; then+  :+else+  exitcode=1+  echo as_func_success failed.+fi++if as_func_failure; then+  exitcode=1+  echo as_func_failure succeeded.+fi++if as_func_ret_success; then+  :+else+  exitcode=1+  echo as_func_ret_success failed.+fi++if as_func_ret_failure; then+  exitcode=1+  echo as_func_ret_failure succeeded.+fi++if ( set x; as_func_ret_success y && test x = \"\$1\" ); then+  :+else+  exitcode=1+  echo positional parameters were not saved.+fi++test \$exitcode = 0) || { (exit 1); exit 1; }++(+  as_lineno_1=\$LINENO+  as_lineno_2=\$LINENO+  test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" &&+  test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; }+") 2> /dev/null; then+  :+else+  as_candidate_shells=+    as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH+do+  IFS=$as_save_IFS+  test -z "$as_dir" && as_dir=.+  case $as_dir in+	 /*)+	   for as_base in sh bash ksh sh5; do+	     as_candidate_shells="$as_candidate_shells $as_dir/$as_base"+	   done;;+       esac+done+IFS=$as_save_IFS+++      for as_shell in $as_candidate_shells $SHELL; do+	 # Try only shells that exist, to save several forks.+	 if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&+		{ ("$as_shell") 2> /dev/null <<\_ASEOF+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+  emulate sh+  NULLCMD=:+  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+  # is contrary to our usage.  Disable this feature.+  alias -g '${1+"$@"}'='"$@"'+  setopt NO_GLOB_SUBST+else+  case `(set -o) 2>/dev/null` in+  *posix*) set -o posix ;;+esac++fi+++:+_ASEOF+}; then+  CONFIG_SHELL=$as_shell+	       as_have_required=yes+	       if { "$as_shell" 2> /dev/null <<\_ASEOF+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+  emulate sh+  NULLCMD=:+  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+  # is contrary to our usage.  Disable this feature.+  alias -g '${1+"$@"}'='"$@"'+  setopt NO_GLOB_SUBST+else+  case `(set -o) 2>/dev/null` in+  *posix*) set -o posix ;;+esac++fi+++:+(as_func_return () {+  (exit $1)+}+as_func_success () {+  as_func_return 0+}+as_func_failure () {+  as_func_return 1+}+as_func_ret_success () {+  return 0+}+as_func_ret_failure () {+  return 1+}++exitcode=0+if as_func_success; then+  :+else+  exitcode=1+  echo as_func_success failed.+fi++if as_func_failure; then+  exitcode=1+  echo as_func_failure succeeded.+fi++if as_func_ret_success; then+  :+else+  exitcode=1+  echo as_func_ret_success failed.+fi++if as_func_ret_failure; then+  exitcode=1+  echo as_func_ret_failure succeeded.+fi++if ( set x; as_func_ret_success y && test x = "$1" ); then+  :+else+  exitcode=1+  echo positional parameters were not saved.+fi++test $exitcode = 0) || { (exit 1); exit 1; }++(+  as_lineno_1=$LINENO+  as_lineno_2=$LINENO+  test "x$as_lineno_1" != "x$as_lineno_2" &&+  test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; }++_ASEOF+}; then+  break+fi++fi++      done++      if test "x$CONFIG_SHELL" != x; then+  for as_var in BASH_ENV ENV+        do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+        done+        export CONFIG_SHELL+        exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"}+fi+++    if test $as_have_required = no; then+  echo This script requires a shell more modern than all the+      echo shells that I found on your system.  Please install a+      echo modern shell, or manually run the script under such a+      echo shell if you do have one.+      { (exit 1); exit 1; }+fi+++fi++fi++++(eval "as_func_return () {+  (exit \$1)+}+as_func_success () {+  as_func_return 0+}+as_func_failure () {+  as_func_return 1+}+as_func_ret_success () {+  return 0+}+as_func_ret_failure () {+  return 1+}++exitcode=0+if as_func_success; then+  :+else+  exitcode=1+  echo as_func_success failed.+fi++if as_func_failure; then+  exitcode=1+  echo as_func_failure succeeded.+fi++if as_func_ret_success; then+  :+else+  exitcode=1+  echo as_func_ret_success failed.+fi++if as_func_ret_failure; then+  exitcode=1+  echo as_func_ret_failure succeeded.+fi++if ( set x; as_func_ret_success y && test x = \"\$1\" ); then+  :+else+  exitcode=1+  echo positional parameters were not saved.+fi++test \$exitcode = 0") || {+  echo No shell found that supports shell functions.+  echo Please tell autoconf@gnu.org about your system,+  echo including any error possibly output before this+  echo message+}++++  as_lineno_1=$LINENO+  as_lineno_2=$LINENO+  test "x$as_lineno_1" != "x$as_lineno_2" &&+  test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {++  # Create $as_me.lineno as a copy of $as_myself, but with $LINENO+  # uniformly replaced by the line number.  The first 'sed' inserts a+  # line-number line after each line using $LINENO; the second 'sed'+  # does the real work.  The second script uses 'N' to pair each+  # line-number line with the line containing $LINENO, and appends+  # trailing '-' during substitution so that $LINENO is not a special+  # case at line end.+  # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the+  # scripts with optimization help from Paolo Bonzini.  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" ||+    { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2+   { (exit 1); exit 1; }; }++  # 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+}+++if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then+  as_dirname=dirname+else+  as_dirname=false+fi++ECHO_C= ECHO_N= ECHO_T=+case `echo -n x` in+-n*)+  case `echo 'x\c'` in+  *c*) ECHO_T='	';;	# ECHO_T is single tab character.+  *)   ECHO_C='\c';;+  esac;;+*)+  ECHO_N='-n';;+esac++if expr a : '\(a\)' >/dev/null 2>&1 &&+   test "X`expr 00001 : '.*\(...\)'`" = X001; then+  as_expr=expr+else+  as_expr=false+fi++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+fi+echo >conf$$.file+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 -p'.+  ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||+    as_ln_s='cp -p'+elif ln conf$$.file conf$$ 2>/dev/null; then+  as_ln_s=ln+else+  as_ln_s='cp -p'+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=:+else+  test -d ./-p && rmdir ./-p+  as_mkdir_p=false+fi++if test -x / >/dev/null 2>&1; then+  as_test_x='test -x'+else+  if ls -dL / >/dev/null 2>&1; then+    as_ls_L_option=L+  else+    as_ls_L_option=+  fi+  as_test_x='+    eval sh -c '\''+      if test -d "$1"; then+        test -d "$1/.";+      else+	case $1 in+        -*)set "./$1";;+	esac;+	case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in+	???[sx]*):;;*)false;;esac;fi+    '\'' sh+  '+fi+as_executable_p=$as_test_x++# 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 7<&0 </dev/null 6>&1++# Name of the host.+# hostname on some systems (SVR3.2, 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=+SHELL=${CONFIG_SHELL-/bin/sh}++# 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'++ac_unique_file="include/HsBase.h"+# Factoring default headers for most tests.+ac_includes_default="\+#include <stdio.h>+#ifdef HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif+#ifdef HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif+#ifdef STDC_HEADERS+# include <stdlib.h>+# include <stddef.h>+#else+# ifdef HAVE_STDLIB_H+#  include <stdlib.h>+# endif+#endif+#ifdef HAVE_STRING_H+# if !defined STDC_HEADERS && defined HAVE_MEMORY_H+#  include <memory.h>+# endif+# include <string.h>+#endif+#ifdef HAVE_STRINGS_H+# include <strings.h>+#endif+#ifdef HAVE_INTTYPES_H+# include <inttypes.h>+#endif+#ifdef HAVE_STDINT_H+# include <stdint.h>+#endif+#ifdef HAVE_UNISTD_H+# include <unistd.h>+#endif"++ac_subst_vars='SHELL+PATH_SEPARATOR+PACKAGE_NAME+PACKAGE_TARNAME+PACKAGE_VERSION+PACKAGE_STRING+PACKAGE_BUGREPORT+exec_prefix+prefix+program_transform_name+bindir+sbindir+libexecdir+datarootdir+datadir+sysconfdir+sharedstatedir+localstatedir+includedir+oldincludedir+docdir+infodir+htmldir+dvidir+pdfdir+psdir+libdir+localedir+mandir+DEFS+ECHO_C+ECHO_N+ECHO_T+LIBS+build_alias+host_alias+target_alias+CC+CFLAGS+LDFLAGS+CPPFLAGS+ac_ct_CC+EXEEXT+OBJEXT+CPP+GREP+EGREP+LIBOBJS+LTLIBOBJS'+ac_subst_files=''+      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+# 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'+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=yes ;;+  esac++  # Accept the important Cygnus configure options, so we can diagnose typos.++  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_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`+    # Reject names that are not valid shell variable names.+    expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&+      { echo "$as_me: error: invalid feature name: $ac_feature" >&2+   { (exit 1); exit 1; }; }+    ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`+    eval enable_$ac_feature=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_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`+    # Reject names that are not valid shell variable names.+    expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null &&+      { echo "$as_me: error: invalid feature name: $ac_feature" >&2+   { (exit 1); exit 1; }; }+    ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'`+    eval enable_$ac_feature=\$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 ;;++  -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_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`+    # Reject names that are not valid shell variable names.+    expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&+      { echo "$as_me: error: invalid package name: $ac_package" >&2+   { (exit 1); exit 1; }; }+    ac_package=`echo $ac_package | sed 's/[-.]/_/g'`+    eval with_$ac_package=\$ac_optarg ;;++  -without-* | --without-*)+    ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`+    # Reject names that are not valid shell variable names.+    expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null &&+      { echo "$as_me: error: invalid package name: $ac_package" >&2+   { (exit 1); exit 1; }; }+    ac_package=`echo $ac_package | sed 's/[-.]/_/g'`+    eval with_$ac_package=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 ;;++  -*) { echo "$as_me: error: unrecognized option: $ac_option+Try \`$0 --help' for more information." >&2+   { (exit 1); exit 1; }; }+    ;;++  *=*)+    ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`+    # Reject names that are not valid shell variable names.+    expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&+      { echo "$as_me: error: invalid variable name: $ac_envvar" >&2+   { (exit 1); exit 1; }; }+    eval $ac_envvar=\$ac_optarg+    export $ac_envvar ;;++  *)+    # FIXME: should be removed in autoconf 3.0.+    echo "$as_me: WARNING: you should use --build, --host, --target" >&2+    expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&+      echo "$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'`+  { echo "$as_me: error: missing argument to $ac_option" >&2+   { (exit 1); exit 1; }; }+fi++# Be sure to have absolute directory names.+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+do+  eval ac_val=\$$ac_var+  case $ac_val in+    [\\/$]* | ?:[\\/]* )  continue;;+    NONE | '' ) case $ac_var in *prefix ) continue;; esac;;+  esac+  { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2+   { (exit 1); exit 1; }; }+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+    echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.+    If a cross compiler is detected then cross compile mode will be used." >&2+  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 .` ||+  { echo "$as_me: error: Working directory cannot be determined" >&2+   { (exit 1); exit 1; }; }+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||+  { echo "$as_me: error: pwd does not report name of working directory" >&2+   { (exit 1); exit 1; }; }+++# 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 -- "$0" ||+$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+	 X"$0" : 'X\(//\)[^/]' \| \+	 X"$0" : 'X\(//\)$' \| \+	 X"$0" : 'X\(/\)' \| . 2>/dev/null ||+echo X"$0" |+    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 .."+  { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2+   { (exit 1); exit 1; }; }+fi+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"+ac_abs_confdir=`(+	cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2+   { (exit 1); exit 1; }; }+	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]+  --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-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)+C compiler++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    C/C++/Objective 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" || continue+    ac_builddir=.++case "$ac_dir" in+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;+*)+  ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`+  # A ".." for each directory in $ac_dir_suffix.+  ac_top_builddir_sub=`echo "$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 guested configure.+    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+      echo "$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.61++Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,+2002, 2003, 2004, 2005, 2006 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+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.61.  Invocation command line was++  $ $0 $@++_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+  test -z "$as_dir" && as_dir=.+  echo "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=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;+    esac+    case $ac_pass in+    1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;+    2)+      ac_configure_args1="$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+      ac_configure_args="$ac_configure_args '$ac_arg'"+      ;;+    esac+  done+done+$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }+$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export 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=$?+  # Save into config.log some information that might help in debugging.+  {+    echo++    cat <<\_ASBOX+## ---------------- ##+## Cache variables. ##+## ---------------- ##+_ASBOX+    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_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;+      esac+      case $ac_var in #(+      _ | IFS | as_nl) ;; #(+      *) $as_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++    cat <<\_ASBOX+## ----------------- ##+## Output variables. ##+## ----------------- ##+_ASBOX+    echo+    for ac_var in $ac_subst_vars+    do+      eval ac_val=\$$ac_var+      case $ac_val in+      *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;+      esac+      echo "$ac_var='\''$ac_val'\''"+    done | sort+    echo++    if test -n "$ac_subst_files"; then+      cat <<\_ASBOX+## ------------------- ##+## File substitutions. ##+## ------------------- ##+_ASBOX+      echo+      for ac_var in $ac_subst_files+      do+	eval ac_val=\$$ac_var+	case $ac_val in+	*\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;+	esac+	echo "$ac_var='\''$ac_val'\''"+      done | sort+      echo+    fi++    if test -s confdefs.h; then+      cat <<\_ASBOX+## ----------- ##+## confdefs.h. ##+## ----------- ##+_ASBOX+      echo+      cat confdefs.h+      echo+    fi+    test "$ac_signal" != 0 &&+      echo "$as_me: caught signal $ac_signal"+    echo "$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'; { (exit 1); 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++# Predefined preprocessor variables.++cat >>confdefs.h <<_ACEOF+#define PACKAGE_NAME "$PACKAGE_NAME"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_VERSION "$PACKAGE_VERSION"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_STRING "$PACKAGE_STRING"+_ACEOF+++cat >>confdefs.h <<_ACEOF+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"+_ACEOF+++# Let the site file select an alternate cache file if it wants to.+# Prefer explicitly selected file to automatically selected ones.+if test -n "$CONFIG_SITE"; then+  set x "$CONFIG_SITE"+elif test "x$prefix" != xNONE; then+  set x "$prefix/share/config.site" "$prefix/etc/config.site"+else+  set x "$ac_default_prefix/share/config.site" \+	"$ac_default_prefix/etc/config.site"+fi+shift+for ac_site_file+do+  if test -r "$ac_site_file"; then+    { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5+echo "$as_me: loading site script $ac_site_file" >&6;}+    sed 's/^/| /' "$ac_site_file" >&5+    . "$ac_site_file"+  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.+  if test -f "$cache_file"; then+    { echo "$as_me:$LINENO: loading cache $cache_file" >&5+echo "$as_me: loading cache $cache_file" >&6;}+    case $cache_file in+      [\\/]* | ?:[\\/]* ) . "$cache_file";;+      *)                      . "./$cache_file";;+    esac+  fi+else+  { echo "$as_me:$LINENO: creating cache $cache_file" >&5+echo "$as_me: creating cache $cache_file" >&6;}+  >$cache_file+fi++# 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,)+      { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5+echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}+      ac_cache_corrupted=: ;;+    ,set)+      { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5+echo "$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+	{ echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5+echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}+	{ echo "$as_me:$LINENO:   former value:  $ac_old_val" >&5+echo "$as_me:   former value:  $ac_old_val" >&2;}+	{ echo "$as_me:$LINENO:   current value: $ac_new_val" >&5+echo "$as_me:   current value: $ac_new_val" >&2;}+	ac_cache_corrupted=:+      fi;;+  esac+  # Pass precious variables to config.status.+  if test "$ac_new_set" = set; then+    case $ac_new_val in+    *\'*) ac_arg=$ac_var=`echo "$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.+      *) ac_configure_args="$ac_configure_args '$ac_arg'" ;;+    esac+  fi+done+if $ac_cache_corrupted; then+  { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5+echo "$as_me: error: changes in the environment can compromise the build" >&2;}+  { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5+echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}+   { (exit 1); exit 1; }; }+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++++# Safety check: Ensure that we are in the correct source directory.+++ac_config_headers="$ac_config_headers include/HsBaseConfig.h"++++# Check whether --with-cc was given.+if test "${with_cc+set}" = set; then+  withval=$with_cc; CC=$withval+fi++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+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+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  for ac_exec_ext in '' $ac_executable_extensions; do+  if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+    ac_cv_prog_CC="${ac_tool_prefix}gcc"+    echo "$as_me:$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+  { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}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+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  for ac_exec_ext in '' $ac_executable_extensions; do+  if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+    ac_cv_prog_ac_ct_CC="gcc"+    echo "$as_me:$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+  { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5+echo "${ECHO_T}$ac_ct_CC" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}no" >&6; }+fi++  if test "x$ac_ct_CC" = x; then+    CC=""+  else+    case $cross_compiling:$ac_tool_warned in+yes:)+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet.  If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&5+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet.  If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&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+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  for ac_exec_ext in '' $ac_executable_extensions; do+  if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+    ac_cv_prog_CC="${ac_tool_prefix}cc"+    echo "$as_me:$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+  { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}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+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  for ac_exec_ext in '' $ac_executable_extensions; do+  if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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"+    echo "$as_me:$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+  { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}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+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  for ac_exec_ext in '' $ac_executable_extensions; do+  if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+    ac_cv_prog_CC="$ac_tool_prefix$ac_prog"+    echo "$as_me:$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+  { echo "$as_me:$LINENO: result: $CC" >&5+echo "${ECHO_T}$CC" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}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+{ echo "$as_me:$LINENO: checking for $ac_word" >&5+echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }+if test "${ac_cv_prog_ac_ct_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  for ac_exec_ext in '' $ac_executable_extensions; do+  if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+    ac_cv_prog_ac_ct_CC="$ac_prog"+    echo "$as_me:$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+  { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5+echo "${ECHO_T}$ac_ct_CC" >&6; }+else+  { echo "$as_me:$LINENO: result: no" >&5+echo "${ECHO_T}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:)+{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet.  If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&5+echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools+whose name does not start with the host triplet.  If you think this+configuration is useful to you, please write to autoconf@gnu.org." >&2;}+ac_tool_warned=yes ;;+esac+    CC=$ac_ct_CC+  fi+fi++fi+++test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH+See \`config.log' for more details." >&5+echo "$as_me: error: no acceptable C compiler found in \$PATH+See \`config.log' for more details." >&2;}+   { (exit 1); exit 1; }; }++# Provide some information about the compiler.+echo "$as_me:$LINENO: checking for C compiler version" >&5+ac_compiler=`set X $ac_compile; echo $2`+{ (ac_try="$ac_compiler --version >&5"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compiler --version >&5") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }+{ (ac_try="$ac_compiler -v >&5"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compiler -v >&5") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }+{ (ac_try="$ac_compiler -V >&5"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compiler -V >&5") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }++cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{++  ;+  return 0;+}+_ACEOF+ac_clean_files_save=$ac_clean_files+ac_clean_files="$ac_clean_files a.out 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.+{ echo "$as_me:$LINENO: checking for C compiler default output file name" >&5+echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6; }+ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`+#+# List of possible output files, starting from the most likely.+# The algorithm is not robust to junk in `.', hence go to wildcards (a.*)+# only as a last resort.  b.out is created by i960 compilers.+ac_files='a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out'+#+# The IRIX 6 linker writes into existing files which may not be+# executable, retaining their permissions.  Remove them first so a+# subsequent execution test works.+ac_rmfiles=+for ac_file in $ac_files+do+  case $ac_file in+    *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.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 "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link_default") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; 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 | *.o | *.obj )+	;;+    [ab].out )+	# We found the default executable, but exeext='' is most+	# certainly right.+	break;;+    *.* )+        if test "${ac_cv_exeext+set}" = set && 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+  ac_file=''+fi++{ echo "$as_me:$LINENO: result: $ac_file" >&5+echo "${ECHO_T}$ac_file" >&6; }+if test -z "$ac_file"; then+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++{ { echo "$as_me:$LINENO: error: C compiler cannot create executables+See \`config.log' for more details." >&5+echo "$as_me: error: C compiler cannot create executables+See \`config.log' for more details." >&2;}+   { (exit 77); exit 77; }; }+fi++ac_exeext=$ac_cv_exeext++# Check that the compiler produces executables we can run.  If not, either+# the compiler is broken, or we cross compile.+{ echo "$as_me:$LINENO: checking whether the C compiler works" >&5+echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6; }+# FIXME: These cross compiler hacks should be removed for Autoconf 3.0+# If not cross compiling, check that we can run a simple program.+if test "$cross_compiling" != yes; then+  if { ac_try='./$ac_file'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+    cross_compiling=no+  else+    if test "$cross_compiling" = maybe; then+	cross_compiling=yes+    else+	{ { echo "$as_me:$LINENO: error: cannot run C compiled programs.+If you meant to cross compile, use \`--host'.+See \`config.log' for more details." >&5+echo "$as_me: error: cannot run C compiled programs.+If you meant to cross compile, use \`--host'.+See \`config.log' for more details." >&2;}+   { (exit 1); exit 1; }; }+    fi+  fi+fi+{ echo "$as_me:$LINENO: result: yes" >&5+echo "${ECHO_T}yes" >&6; }++rm -f a.out a.exe conftest$ac_cv_exeext b.out+ac_clean_files=$ac_clean_files_save+# Check that the compiler produces executables we can run.  If not, either+# the compiler is broken, or we cross compile.+{ echo "$as_me:$LINENO: checking whether we are cross compiling" >&5+echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6; }+{ echo "$as_me:$LINENO: result: $cross_compiling" >&5+echo "${ECHO_T}$cross_compiling" >&6; }++{ echo "$as_me:$LINENO: checking for suffix of executables" >&5+echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6; }+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; 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 | *.o | *.obj ) ;;+    *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`+	  break;;+    * ) break;;+  esac+done+else+  { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link+See \`config.log' for more details." >&5+echo "$as_me: error: cannot compute suffix of executables: cannot compile and link+See \`config.log' for more details." >&2;}+   { (exit 1); exit 1; }; }+fi++rm -f conftest$ac_cv_exeext+{ echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5+echo "${ECHO_T}$ac_cv_exeext" >&6; }++rm -f conftest.$ac_ext+EXEEXT=$ac_cv_exeext+ac_exeext=$EXEEXT+{ echo "$as_me:$LINENO: checking for suffix of object files" >&5+echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6; }+if test "${ac_cv_objext+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{++  ;+  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 "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; 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 ) ;;+    *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`+       break;;+  esac+done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile+See \`config.log' for more details." >&5+echo "$as_me: error: cannot compute suffix of object files: cannot compile+See \`config.log' for more details." >&2;}+   { (exit 1); exit 1; }; }+fi++rm -f conftest.$ac_cv_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_objext" >&5+echo "${ECHO_T}$ac_cv_objext" >&6; }+OBJEXT=$ac_cv_objext+ac_objext=$OBJEXT+{ echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5+echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6; }+if test "${ac_cv_c_compiler_gnu+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{+#ifndef __GNUC__+       choke me+#endif++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_compiler_gnu=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_compiler_gnu=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+ac_cv_c_compiler_gnu=$ac_compiler_gnu++fi+{ echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5+echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6; }+GCC=`test $ac_compiler_gnu = yes && echo yes`+ac_test_CFLAGS=${CFLAGS+set}+ac_save_CFLAGS=$CFLAGS+{ echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5+echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6; }+if test "${ac_cv_prog_cc_g+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  ac_save_c_werror_flag=$ac_c_werror_flag+   ac_c_werror_flag=yes+   ac_cv_prog_cc_g=no+   CFLAGS="-g"+   cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_prog_cc_g=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	CFLAGS=""+      cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  :+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_c_werror_flag=$ac_save_c_werror_flag+	 CFLAGS="-g"+	 cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_prog_cc_g=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+   ac_c_werror_flag=$ac_save_c_werror_flag+fi+{ echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5+echo "${ECHO_T}$ac_cv_prog_cc_g" >&6; }+if test "$ac_test_CFLAGS" = set; 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+{ echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5+echo $ECHO_N "checking for $CC option to accept ISO C89... $ECHO_C" >&6; }+if test "${ac_cv_prog_cc_c89+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  ac_cv_prog_cc_c89=no+ac_save_CC=$CC+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdarg.h>+#include <stdio.h>+#include <sys/types.h>+#include <sys/stat.h>+/* Most of the following tests are stolen from RCS 5.7's src/conf.sh.  */+struct buf { int x; };+FILE * (*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 don't provoke an error unfortunately, instead are silently treated+   as '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's necessary to write '\x00'==0 to get something+   that's 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 **, FILE *(*)(struct buf *, struct stat *, int), int, int);+int argc;+char **argv;+int+main ()+{+return f (e, argv, 0) != argv[0]  ||  f (e, argv, 1) != argv[1];+  ;+  return 0;+}+_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"+  rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_prog_cc_c89=$ac_arg+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext+  test "x$ac_cv_prog_cc_c89" != "xno" && break+done+rm -f conftest.$ac_ext+CC=$ac_save_CC++fi+# AC_CACHE_VAL+case "x$ac_cv_prog_cc_c89" in+  x)+    { echo "$as_me:$LINENO: result: none needed" >&5+echo "${ECHO_T}none needed" >&6; } ;;+  xno)+    { echo "$as_me:$LINENO: result: unsupported" >&5+echo "${ECHO_T}unsupported" >&6; } ;;+  *)+    CC="$CC $ac_cv_prog_cc_c89"+    { echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5+echo "${ECHO_T}$ac_cv_prog_cc_c89" >&6; } ;;+esac+++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+++# do we have long longs?++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+{ echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5+echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&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+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+      # Double quotes because CPP needs to be expanded+    for CPP in "$CC -E" "$CC -E -traditional-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.+  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+  # <limits.h> exists even on freestanding compilers.+  # 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 >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif+		     Syntax error+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } >/dev/null && {+	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+	 test ! -s conftest.err+       }; then+  :+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++  # Broken: fails on valid input.+continue+fi++rm -f conftest.err conftest.$ac_ext++  # OK, works on sane cases.  Now check whether nonexistent headers+  # can be detected and how.+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <ac_nonexistent.h>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } >/dev/null && {+	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+	 test ! -s conftest.err+       }; then+  # Broken: success on invalid input.+continue+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++  # Passes both tests.+ac_preproc_ok=:+break+fi++rm -f conftest.err conftest.$ac_ext++done+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.+rm -f 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+{ echo "$as_me:$LINENO: result: $CPP" >&5+echo "${ECHO_T}$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.+  # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+  # <limits.h> exists even on freestanding compilers.+  # 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 >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif+		     Syntax error+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } >/dev/null && {+	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+	 test ! -s conftest.err+       }; then+  :+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++  # Broken: fails on valid input.+continue+fi++rm -f conftest.err conftest.$ac_ext++  # OK, works on sane cases.  Now check whether nonexistent headers+  # can be detected and how.+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <ac_nonexistent.h>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } >/dev/null && {+	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+	 test ! -s conftest.err+       }; then+  # Broken: success on invalid input.+continue+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++  # Passes both tests.+ac_preproc_ok=:+break+fi++rm -f conftest.err conftest.$ac_ext++done+# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.+rm -f conftest.err conftest.$ac_ext+if $ac_preproc_ok; then+  :+else+  { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check+See \`config.log' for more details." >&5+echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check+See \`config.log' for more details." >&2;}+   { (exit 1); exit 1; }; }+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+++{ echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5+echo $ECHO_N "checking for grep that handles long lines and -e... $ECHO_C" >&6; }+if test "${ac_cv_path_GREP+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  # Extract the first word of "grep ggrep" to use in msg output+if test -z "$GREP"; then+set dummy grep ggrep; ac_prog_name=$2+if test "${ac_cv_path_GREP+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  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"+    { test -f "$ac_path_GREP" && $as_test_x "$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+  echo $ECHO_N "0123456789$ECHO_C" >"conftest.in"+  while :+  do+    cat "conftest.in" "conftest.in" >"conftest.tmp"+    mv "conftest.tmp" "conftest.in"+    cp "conftest.in" "conftest.nl"+    echo '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+    ac_count=`expr $ac_count + 1`+    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+++fi++GREP="$ac_cv_path_GREP"+if test -z "$GREP"; then+  { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5+echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;}+   { (exit 1); exit 1; }; }+fi++else+  ac_cv_path_GREP=$GREP+fi+++fi+{ echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5+echo "${ECHO_T}$ac_cv_path_GREP" >&6; }+ GREP="$ac_cv_path_GREP"+++{ echo "$as_me:$LINENO: checking for egrep" >&5+echo $ECHO_N "checking for egrep... $ECHO_C" >&6; }+if test "${ac_cv_path_EGREP+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  if echo a | $GREP -E '(a|b)' >/dev/null 2>&1+   then ac_cv_path_EGREP="$GREP -E"+   else+     # Extract the first word of "egrep" to use in msg output+if test -z "$EGREP"; then+set dummy egrep; ac_prog_name=$2+if test "${ac_cv_path_EGREP+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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+  test -z "$as_dir" && as_dir=.+  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"+    { test -f "$ac_path_EGREP" && $as_test_x "$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+  echo $ECHO_N "0123456789$ECHO_C" >"conftest.in"+  while :+  do+    cat "conftest.in" "conftest.in" >"conftest.tmp"+    mv "conftest.tmp" "conftest.in"+    cp "conftest.in" "conftest.nl"+    echo '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+    ac_count=`expr $ac_count + 1`+    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+++fi++EGREP="$ac_cv_path_EGREP"+if test -z "$EGREP"; then+  { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5+echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;}+   { (exit 1); exit 1; }; }+fi++else+  ac_cv_path_EGREP=$EGREP+fi+++   fi+fi+{ echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5+echo "${ECHO_T}$ac_cv_path_EGREP" >&6; }+ EGREP="$ac_cv_path_EGREP"+++{ echo "$as_me:$LINENO: checking for ANSI C header files" >&5+echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6; }+if test "${ac_cv_header_stdc+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdlib.h>+#include <stdarg.h>+#include <string.h>+#include <float.h>++int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_header_stdc=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_header_stdc=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++if test $ac_cv_header_stdc = yes; then+  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <string.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "memchr" >/dev/null 2>&1; then+  :+else+  ac_cv_header_stdc=no+fi+rm -f conftest*++fi++if test $ac_cv_header_stdc = yes; then+  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdlib.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "free" >/dev/null 2>&1; then+  :+else+  ac_cv_header_stdc=no+fi+rm -f conftest*++fi++if test $ac_cv_header_stdc = yes; then+  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.+  if test "$cross_compiling" = yes; then+  :+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <ctype.h>+#include <stdlib.h>+#if ((' ' & 0x0FF) == 0x020)+# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')+# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))+#else+# define ISLOWER(c) \+		   (('a' <= (c) && (c) <= 'i') \+		     || ('j' <= (c) && (c) <= 'r') \+		     || ('s' <= (c) && (c) <= 'z'))+# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))+#endif++#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))+int+main ()+{+  int i;+  for (i = 0; i < 256; i++)+    if (XOR (islower (i), ISLOWER (i))+	|| toupper (i) != TOUPPER (i))+      return 2;+  return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  :+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+ac_cv_header_stdc=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++fi+fi+{ echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5+echo "${ECHO_T}$ac_cv_header_stdc" >&6; }+if test $ac_cv_header_stdc = yes; then++cat >>confdefs.h <<\_ACEOF+#define STDC_HEADERS 1+_ACEOF++fi++# On IRIX 5.3, sys/types and inttypes.h are conflicting.++++++++++for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \+		  inttypes.h stdint.h unistd.h+do+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+$ac_includes_default++#include <$ac_header>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  eval "$as_ac_Header=yes"+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	eval "$as_ac_Header=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_Header'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1+_ACEOF++fi++done+++{ echo "$as_me:$LINENO: checking for long long" >&5+echo $ECHO_N "checking for long long... $ECHO_C" >&6; }+if test "${ac_cv_type_long_long+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+$ac_includes_default+typedef long long ac__type_new_;+int+main ()+{+if ((ac__type_new_ *) 0)+  return 0;+if (sizeof (ac__type_new_))+  return 0;+  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_type_long_long=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_type_long_long=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_type_long_long" >&5+echo "${ECHO_T}$ac_cv_type_long_long" >&6; }+if test $ac_cv_type_long_long = yes; then++cat >>confdefs.h <<_ACEOF+#define HAVE_LONG_LONG 1+_ACEOF+++fi+++{ echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5+echo $ECHO_N "checking for an ANSI C-conforming const... $ECHO_C" >&6; }+if test "${ac_cv_c_const+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++int+main ()+{+/* FIXME: Include the comments suggested by Paul. */+#ifndef __cplusplus+  /* Ultrix mips cc rejects this.  */+  typedef int charset[2];+  const charset cs;+  /* SunOS 4.1.1 cc rejects this.  */+  char const *const *pcpcc;+  char **ppc;+  /* NEC SVR4.0.2 mips cc rejects this.  */+  struct point {int x, y;};+  static struct point const zero = {0,0};+  /* AIX XL C 1.02.0.0 rejects this.+     It does not let you subtract one const X* pointer from another in+     an arm of an if-expression whose if-part is not a constant+     expression */+  const char *g = "string";+  pcpcc = &g + (g ? g-g : 0);+  /* HPUX 7.0 cc rejects these. */+  ++pcpcc;+  ppc = (char**) pcpcc;+  pcpcc = (char const *const *) ppc;+  { /* SCO 3.2v4 cc rejects this.  */+    char *t;+    char const *s = 0 ? (char *) 0 : (char const *) 0;++    *t++ = 0;+    if (s) return 0;+  }+  { /* Someone thinks the Sun supposedly-ANSI compiler will reject this.  */+    int x[] = {25, 17};+    const int *foo = &x[0];+    ++foo;+  }+  { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */+    typedef const int *iptr;+    iptr p = 0;+    ++p;+  }+  { /* AIX XL C 1.02.0.0 rejects this saying+       "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */+    struct s { int j; const int *ap[3]; };+    struct s *b; b->j = 5;+  }+  { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */+    const int foo = 10;+    if (!foo) return 0;+  }+  return !cs[0] && !zero.x;+#endif++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_c_const=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_c_const=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+{ echo "$as_me:$LINENO: result: $ac_cv_c_const" >&5+echo "${ECHO_T}$ac_cv_c_const" >&6; }+if test $ac_cv_c_const = no; then++cat >>confdefs.h <<\_ACEOF+#define const+_ACEOF++fi+++{ echo "$as_me:$LINENO: checking for ANSI C header files" >&5+echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6; }+if test "${ac_cv_header_stdc+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdlib.h>+#include <stdarg.h>+#include <string.h>+#include <float.h>++int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_header_stdc=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_cv_header_stdc=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext++if test $ac_cv_header_stdc = yes; then+  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <string.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "memchr" >/dev/null 2>&1; then+  :+else+  ac_cv_header_stdc=no+fi+rm -f conftest*++fi++if test $ac_cv_header_stdc = yes; then+  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdlib.h>++_ACEOF+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |+  $EGREP "free" >/dev/null 2>&1; then+  :+else+  ac_cv_header_stdc=no+fi+rm -f conftest*++fi++if test $ac_cv_header_stdc = yes; then+  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.+  if test "$cross_compiling" = yes; then+  :+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <ctype.h>+#include <stdlib.h>+#if ((' ' & 0x0FF) == 0x020)+# define ISLOWER(c) ('a' <= (c) && (c) <= 'z')+# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))+#else+# define ISLOWER(c) \+		   (('a' <= (c) && (c) <= 'i') \+		     || ('j' <= (c) && (c) <= 'r') \+		     || ('s' <= (c) && (c) <= 'z'))+# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c))+#endif++#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))+int+main ()+{+  int i;+  for (i = 0; i < 256; i++)+    if (XOR (islower (i), ISLOWER (i))+	|| toupper (i) != TOUPPER (i))+      return 2;+  return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  :+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+ac_cv_header_stdc=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++fi+fi+{ echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5+echo "${ECHO_T}$ac_cv_header_stdc" >&6; }+if test $ac_cv_header_stdc = yes; then++cat >>confdefs.h <<\_ACEOF+#define STDC_HEADERS 1+_ACEOF++fi+++# check for specific header (.h) files that we are interested in+++++++++++++++++++++++++for ac_header in ctype.h dirent.h errno.h fcntl.h inttypes.h limits.h signal.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+do+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  { echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+else+  # Is the header compilable?+{ echo "$as_me:$LINENO: checking $ac_header usability" >&5+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+$ac_includes_default+#include <$ac_header>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_header_compiler=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_header_compiler=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5+echo "${ECHO_T}$ac_header_compiler" >&6; }++# Is the header present?+{ echo "$as_me:$LINENO: checking $ac_header presence" >&5+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <$ac_header>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } >/dev/null && {+	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+	 test ! -s conftest.err+       }; then+  ac_header_preproc=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++  ac_header_preproc=no+fi++rm -f conftest.err conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5+echo "${ECHO_T}$ac_header_preproc" >&6; }++# So?  What about this header?+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in+  yes:no: )+    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}+    ac_header_preproc=yes+    ;;+  no:yes:* )+    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5+echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5+echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5+echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5+echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}+    ( cat <<\_ASBOX+## ------------------------------------ ##+## Report this to libraries@haskell.org ##+## ------------------------------------ ##+_ASBOX+     ) | sed "s/^/$as_me: WARNING:     /" >&2+    ;;+esac+{ echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  eval "$as_ac_Header=\$ac_header_preproc"+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }++fi+if test `eval echo '${'$as_ac_Header'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1+_ACEOF++fi++done+++# 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+set}" = set; then+  enableval=$enable_largefile;+fi++if test "$enable_largefile" != no; then++  { echo "$as_me:$LINENO: checking for special C compiler options needed for large files" >&5+echo $ECHO_N "checking for special C compiler options needed for large files... $ECHO_C" >&6; }+if test "${ac_cv_sys_largefile_CC+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  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 >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* 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 << 62) - 1 + ((off_t) 1 << 62))+  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721+		       && LARGE_OFF_T % 2147483647 == 1)+		      ? 1 : -1];+int+main ()+{++  ;+  return 0;+}+_ACEOF+	 rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext+	 CC="$CC -n32"+	 rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_sys_largefile_CC=' -n32'; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext+	 break+       done+       CC=$ac_save_CC+       rm -f conftest.$ac_ext+    fi+fi+{ echo "$as_me:$LINENO: result: $ac_cv_sys_largefile_CC" >&5+echo "${ECHO_T}$ac_cv_sys_largefile_CC" >&6; }+  if test "$ac_cv_sys_largefile_CC" != no; then+    CC=$CC$ac_cv_sys_largefile_CC+  fi++  { echo "$as_me:$LINENO: checking for _FILE_OFFSET_BITS value needed for large files" >&5+echo $ECHO_N "checking for _FILE_OFFSET_BITS value needed for large files... $ECHO_C" >&6; }+if test "${ac_cv_sys_file_offset_bits+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  while :; do+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* 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 << 62) - 1 + ((off_t) 1 << 62))+  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721+		       && LARGE_OFF_T % 2147483647 == 1)+		      ? 1 : -1];+int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_sys_file_offset_bits=no; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* 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 << 62) - 1 + ((off_t) 1 << 62))+  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721+		       && LARGE_OFF_T % 2147483647 == 1)+		      ? 1 : -1];+int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_sys_file_offset_bits=64; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  ac_cv_sys_file_offset_bits=unknown+  break+done+fi+{ echo "$as_me:$LINENO: result: $ac_cv_sys_file_offset_bits" >&5+echo "${ECHO_T}$ac_cv_sys_file_offset_bits" >&6; }+case $ac_cv_sys_file_offset_bits in #(+  no | unknown) ;;+  *)+cat >>confdefs.h <<_ACEOF+#define _FILE_OFFSET_BITS $ac_cv_sys_file_offset_bits+_ACEOF+;;+esac+rm -f conftest*+  if test $ac_cv_sys_file_offset_bits = unknown; then+    { echo "$as_me:$LINENO: checking for _LARGE_FILES value needed for large files" >&5+echo $ECHO_N "checking for _LARGE_FILES value needed for large files... $ECHO_C" >&6; }+if test "${ac_cv_sys_large_files+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  while :; do+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* 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 << 62) - 1 + ((off_t) 1 << 62))+  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721+		       && LARGE_OFF_T % 2147483647 == 1)+		      ? 1 : -1];+int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_sys_large_files=no; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* 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 << 62) - 1 + ((off_t) 1 << 62))+  int off_t_is_large[(LARGE_OFF_T % 2147483629 == 721+		       && LARGE_OFF_T % 2147483647 == 1)+		      ? 1 : -1];+int+main ()+{++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_cv_sys_large_files=1; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5+++fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  ac_cv_sys_large_files=unknown+  break+done+fi+{ echo "$as_me:$LINENO: result: $ac_cv_sys_large_files" >&5+echo "${ECHO_T}$ac_cv_sys_large_files" >&6; }+case $ac_cv_sys_large_files in #(+  no | unknown) ;;+  *)+cat >>confdefs.h <<_ACEOF+#define _LARGE_FILES $ac_cv_sys_large_files+_ACEOF+;;+esac+rm -f conftest*+  fi+fi++++for ac_header in wctype.h+do+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  { echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+else+  # Is the header compilable?+{ echo "$as_me:$LINENO: checking $ac_header usability" >&5+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+$ac_includes_default+#include <$ac_header>+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_header_compiler=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_header_compiler=no+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5+echo "${ECHO_T}$ac_header_compiler" >&6; }++# Is the header present?+{ echo "$as_me:$LINENO: checking $ac_header presence" >&5+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; }+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <$ac_header>+_ACEOF+if { (ac_try="$ac_cpp conftest.$ac_ext"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } >/dev/null && {+	 test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||+	 test ! -s conftest.err+       }; then+  ac_header_preproc=yes+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++  ac_header_preproc=no+fi++rm -f conftest.err conftest.$ac_ext+{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5+echo "${ECHO_T}$ac_header_preproc" >&6; }++# So?  What about this header?+case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in+  yes:no: )+    { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}+    ac_header_preproc=yes+    ;;+  no:yes:* )+    { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header:     check for missing prerequisite headers?" >&5+echo "$as_me: WARNING: $ac_header:     check for missing prerequisite headers?" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5+echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&5+echo "$as_me: WARNING: $ac_header:     section \"Present But Cannot Be Compiled\"" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}+    { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5+echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}+    ( cat <<\_ASBOX+## ------------------------------------ ##+## Report this to libraries@haskell.org ##+## ------------------------------------ ##+_ASBOX+     ) | sed "s/^/$as_me: WARNING:     /" >&2+    ;;+esac+{ echo "$as_me:$LINENO: checking for $ac_header" >&5+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; }+if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  eval "$as_ac_Header=\$ac_header_preproc"+fi+ac_res=`eval echo '${'$as_ac_Header'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }++fi+if test `eval echo '${'$as_ac_Header'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1+_ACEOF++for ac_func in iswspace+do+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_func" >&5+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.+   For example, HP-UX 11i <limits.h> declares gettimeofday.  */+#define $ac_func innocuous_$ac_func++/* System header to define __stub macros and hopefully few prototypes,+    which can conflict with char $ac_func (); below.+    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+    <limits.h> exists even on freestanding compilers.  */++#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif++#undef $ac_func++/* 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 $ac_func ();+/* 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_$ac_func || defined __stub___$ac_func+choke me+#endif++int+main ()+{+return $ac_func ();+  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest$ac_exeext &&+       $as_test_x conftest$ac_exeext; then+  eval "$as_ac_var=yes"+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	eval "$as_ac_var=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+      conftest$ac_exeext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_var'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_var'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1+_ACEOF++fi+done++fi++done+++++for ac_func in lstat readdir_r+do+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_func" >&5+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.+   For example, HP-UX 11i <limits.h> declares gettimeofday.  */+#define $ac_func innocuous_$ac_func++/* System header to define __stub macros and hopefully few prototypes,+    which can conflict with char $ac_func (); below.+    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+    <limits.h> exists even on freestanding compilers.  */++#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif++#undef $ac_func++/* 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 $ac_func ();+/* 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_$ac_func || defined __stub___$ac_func+choke me+#endif++int+main ()+{+return $ac_func ();+  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest$ac_exeext &&+       $as_test_x conftest$ac_exeext; then+  eval "$as_ac_var=yes"+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	eval "$as_ac_var=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+      conftest$ac_exeext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_var'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_var'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1+_ACEOF++fi+done+++++for ac_func in getclock getrusage times+do+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_func" >&5+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.+   For example, HP-UX 11i <limits.h> declares gettimeofday.  */+#define $ac_func innocuous_$ac_func++/* System header to define __stub macros and hopefully few prototypes,+    which can conflict with char $ac_func (); below.+    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+    <limits.h> exists even on freestanding compilers.  */++#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif++#undef $ac_func++/* 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 $ac_func ();+/* 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_$ac_func || defined __stub___$ac_func+choke me+#endif++int+main ()+{+return $ac_func ();+  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest$ac_exeext &&+       $as_test_x conftest$ac_exeext; then+  eval "$as_ac_var=yes"+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	eval "$as_ac_var=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+      conftest$ac_exeext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_var'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_var'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1+_ACEOF++fi+done++++for ac_func in _chsize ftruncate+do+as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking for $ac_func" >&5+echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; }+if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func.+   For example, HP-UX 11i <limits.h> declares gettimeofday.  */+#define $ac_func innocuous_$ac_func++/* System header to define __stub macros and hopefully few prototypes,+    which can conflict with char $ac_func (); below.+    Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+    <limits.h> exists even on freestanding compilers.  */++#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif++#undef $ac_func++/* 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 $ac_func ();+/* 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_$ac_func || defined __stub___$ac_func+choke me+#endif++int+main ()+{+return $ac_func ();+  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest$ac_exeext &&+       $as_test_x conftest$ac_exeext; then+  eval "$as_ac_var=yes"+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	eval "$as_ac_var=no"+fi++rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \+      conftest$ac_exeext conftest.$ac_ext+fi+ac_res=`eval echo '${'$as_ac_var'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+if test `eval echo '${'$as_ac_var'}'` = yes; then+  cat >>confdefs.h <<_ACEOF+#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1+_ACEOF++fi+done+++# map standard C types and ISO types to Haskell types+{ echo "$as_me:$LINENO: checking Haskell type for char" >&5+echo $ECHO_N "checking Haskell type for char... $ECHO_C" >&6; }+if test "${fptools_cv_htype_char+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_char=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_char=NotReallyATypeCross; fptools_cv_htype_sup_char=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef char testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_char=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_char=NotReallyAType; fptools_cv_htype_sup_char=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_char" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_char" >&5+echo "${ECHO_T}$fptools_cv_htype_char" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_CHAR $fptools_cv_htype_char+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for signed char" >&5+echo $ECHO_N "checking Haskell type for signed char... $ECHO_C" >&6; }+if test "${fptools_cv_htype_signed_char+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_signed_char=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_signed_char=NotReallyATypeCross; fptools_cv_htype_sup_signed_char=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef signed char testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_signed_char=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_signed_char=NotReallyAType; fptools_cv_htype_sup_signed_char=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_signed_char" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_signed_char" >&5+echo "${ECHO_T}$fptools_cv_htype_signed_char" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_SIGNED_CHAR $fptools_cv_htype_signed_char+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for unsigned char" >&5+echo $ECHO_N "checking Haskell type for unsigned char... $ECHO_C" >&6; }+if test "${fptools_cv_htype_unsigned_char+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_unsigned_char=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_unsigned_char=NotReallyATypeCross; fptools_cv_htype_sup_unsigned_char=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef unsigned char testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_unsigned_char=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_unsigned_char=NotReallyAType; fptools_cv_htype_sup_unsigned_char=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_unsigned_char" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_unsigned_char" >&5+echo "${ECHO_T}$fptools_cv_htype_unsigned_char" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UNSIGNED_CHAR $fptools_cv_htype_unsigned_char+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for short" >&5+echo $ECHO_N "checking Haskell type for short... $ECHO_C" >&6; }+if test "${fptools_cv_htype_short+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_short=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_short=NotReallyATypeCross; fptools_cv_htype_sup_short=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef short testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_short=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_short=NotReallyAType; fptools_cv_htype_sup_short=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_short" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_short" >&5+echo "${ECHO_T}$fptools_cv_htype_short" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_SHORT $fptools_cv_htype_short+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for unsigned short" >&5+echo $ECHO_N "checking Haskell type for unsigned short... $ECHO_C" >&6; }+if test "${fptools_cv_htype_unsigned_short+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_unsigned_short=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_unsigned_short=NotReallyATypeCross; fptools_cv_htype_sup_unsigned_short=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef unsigned short testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_unsigned_short=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_unsigned_short=NotReallyAType; fptools_cv_htype_sup_unsigned_short=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_unsigned_short" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_unsigned_short" >&5+echo "${ECHO_T}$fptools_cv_htype_unsigned_short" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UNSIGNED_SHORT $fptools_cv_htype_unsigned_short+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for int" >&5+echo $ECHO_N "checking Haskell type for int... $ECHO_C" >&6; }+if test "${fptools_cv_htype_int+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_int=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_int=NotReallyATypeCross; fptools_cv_htype_sup_int=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef int testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_int=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_int=NotReallyAType; fptools_cv_htype_sup_int=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_int" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_int" >&5+echo "${ECHO_T}$fptools_cv_htype_int" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_INT $fptools_cv_htype_int+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for unsigned int" >&5+echo $ECHO_N "checking Haskell type for unsigned int... $ECHO_C" >&6; }+if test "${fptools_cv_htype_unsigned_int+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_unsigned_int=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_unsigned_int=NotReallyATypeCross; fptools_cv_htype_sup_unsigned_int=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef unsigned int testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_unsigned_int=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_unsigned_int=NotReallyAType; fptools_cv_htype_sup_unsigned_int=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_unsigned_int" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_unsigned_int" >&5+echo "${ECHO_T}$fptools_cv_htype_unsigned_int" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UNSIGNED_INT $fptools_cv_htype_unsigned_int+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for long" >&5+echo $ECHO_N "checking Haskell type for long... $ECHO_C" >&6; }+if test "${fptools_cv_htype_long+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_long=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_long=NotReallyATypeCross; fptools_cv_htype_sup_long=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef long testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_long=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_long=NotReallyAType; fptools_cv_htype_sup_long=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_long" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_long" >&5+echo "${ECHO_T}$fptools_cv_htype_long" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_LONG $fptools_cv_htype_long+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for unsigned long" >&5+echo $ECHO_N "checking Haskell type for unsigned long... $ECHO_C" >&6; }+if test "${fptools_cv_htype_unsigned_long+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_unsigned_long=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_unsigned_long=NotReallyATypeCross; fptools_cv_htype_sup_unsigned_long=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef unsigned long testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_unsigned_long=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_unsigned_long=NotReallyAType; fptools_cv_htype_sup_unsigned_long=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_unsigned_long" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_unsigned_long" >&5+echo "${ECHO_T}$fptools_cv_htype_unsigned_long" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UNSIGNED_LONG $fptools_cv_htype_unsigned_long+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++if test "$ac_cv_type_long_long" = yes; then+{ echo "$as_me:$LINENO: checking Haskell type for long long" >&5+echo $ECHO_N "checking Haskell type for long long... $ECHO_C" >&6; }+if test "${fptools_cv_htype_long_long+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_long_long=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_long_long=NotReallyATypeCross; fptools_cv_htype_sup_long_long=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef long long testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_long_long=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_long_long=NotReallyAType; fptools_cv_htype_sup_long_long=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_long_long" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_long_long" >&5+echo "${ECHO_T}$fptools_cv_htype_long_long" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_LONG_LONG $fptools_cv_htype_long_long+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for unsigned long long" >&5+echo $ECHO_N "checking Haskell type for unsigned long long... $ECHO_C" >&6; }+if test "${fptools_cv_htype_unsigned_long_long+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_unsigned_long_long=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_unsigned_long_long=NotReallyATypeCross; fptools_cv_htype_sup_unsigned_long_long=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef unsigned long long testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_unsigned_long_long=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_unsigned_long_long=NotReallyAType; fptools_cv_htype_sup_unsigned_long_long=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_unsigned_long_long" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_unsigned_long_long" >&5+echo "${ECHO_T}$fptools_cv_htype_unsigned_long_long" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UNSIGNED_LONG_LONG $fptools_cv_htype_unsigned_long_long+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++fi+{ echo "$as_me:$LINENO: checking Haskell type for float" >&5+echo $ECHO_N "checking Haskell type for float... $ECHO_C" >&6; }+if test "${fptools_cv_htype_float+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_float=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_float=NotReallyATypeCross; fptools_cv_htype_sup_float=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef float testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_float=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_float=NotReallyAType; fptools_cv_htype_sup_float=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_float" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_float" >&5+echo "${ECHO_T}$fptools_cv_htype_float" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_FLOAT $fptools_cv_htype_float+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for double" >&5+echo $ECHO_N "checking Haskell type for double... $ECHO_C" >&6; }+if test "${fptools_cv_htype_double+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_double=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_double=NotReallyATypeCross; fptools_cv_htype_sup_double=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef double testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_double=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_double=NotReallyAType; fptools_cv_htype_sup_double=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_double" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_double" >&5+echo "${ECHO_T}$fptools_cv_htype_double" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_DOUBLE $fptools_cv_htype_double+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for ptrdiff_t" >&5+echo $ECHO_N "checking Haskell type for ptrdiff_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_ptrdiff_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_ptrdiff_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_ptrdiff_t=NotReallyATypeCross; fptools_cv_htype_sup_ptrdiff_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef ptrdiff_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_ptrdiff_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_ptrdiff_t=NotReallyAType; fptools_cv_htype_sup_ptrdiff_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_ptrdiff_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_ptrdiff_t" >&5+echo "${ECHO_T}$fptools_cv_htype_ptrdiff_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_PTRDIFF_T $fptools_cv_htype_ptrdiff_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for size_t" >&5+echo $ECHO_N "checking Haskell type for size_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_size_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_size_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_size_t=NotReallyATypeCross; fptools_cv_htype_sup_size_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef size_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_size_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_size_t=NotReallyAType; fptools_cv_htype_sup_size_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_size_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_size_t" >&5+echo "${ECHO_T}$fptools_cv_htype_size_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_SIZE_T $fptools_cv_htype_size_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for wchar_t" >&5+echo $ECHO_N "checking Haskell type for wchar_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_wchar_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_wchar_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_wchar_t=NotReallyATypeCross; fptools_cv_htype_sup_wchar_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef wchar_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_wchar_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_wchar_t=NotReallyAType; fptools_cv_htype_sup_wchar_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_wchar_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_wchar_t" >&5+echo "${ECHO_T}$fptools_cv_htype_wchar_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_WCHAR_T $fptools_cv_htype_wchar_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++# Int32 is a HACK for non-ISO C compilers+{ echo "$as_me:$LINENO: checking Haskell type for sig_atomic_t" >&5+echo $ECHO_N "checking Haskell type for sig_atomic_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_sig_atomic_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_sig_atomic_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_sig_atomic_t=NotReallyATypeCross; fptools_cv_htype_sup_sig_atomic_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef sig_atomic_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_sig_atomic_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_sig_atomic_t=Int32+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_sig_atomic_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_sig_atomic_t" >&5+echo "${ECHO_T}$fptools_cv_htype_sig_atomic_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_SIG_ATOMIC_T $fptools_cv_htype_sig_atomic_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for clock_t" >&5+echo $ECHO_N "checking Haskell type for clock_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_clock_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_clock_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_clock_t=NotReallyATypeCross; fptools_cv_htype_sup_clock_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef clock_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_clock_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_clock_t=NotReallyAType; fptools_cv_htype_sup_clock_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_clock_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_clock_t" >&5+echo "${ECHO_T}$fptools_cv_htype_clock_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_CLOCK_T $fptools_cv_htype_clock_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for time_t" >&5+echo $ECHO_N "checking Haskell type for time_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_time_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_time_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_time_t=NotReallyATypeCross; fptools_cv_htype_sup_time_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef time_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_time_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_time_t=NotReallyAType; fptools_cv_htype_sup_time_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_time_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_time_t" >&5+echo "${ECHO_T}$fptools_cv_htype_time_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_TIME_T $fptools_cv_htype_time_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for dev_t" >&5+echo $ECHO_N "checking Haskell type for dev_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_dev_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_dev_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_dev_t=NotReallyATypeCross; fptools_cv_htype_sup_dev_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef dev_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_dev_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_dev_t=Word32+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_dev_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_dev_t" >&5+echo "${ECHO_T}$fptools_cv_htype_dev_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_DEV_T $fptools_cv_htype_dev_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for ino_t" >&5+echo $ECHO_N "checking Haskell type for ino_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_ino_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_ino_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_ino_t=NotReallyATypeCross; fptools_cv_htype_sup_ino_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef ino_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_ino_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_ino_t=NotReallyAType; fptools_cv_htype_sup_ino_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_ino_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_ino_t" >&5+echo "${ECHO_T}$fptools_cv_htype_ino_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_INO_T $fptools_cv_htype_ino_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for mode_t" >&5+echo $ECHO_N "checking Haskell type for mode_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_mode_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_mode_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_mode_t=NotReallyATypeCross; fptools_cv_htype_sup_mode_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef mode_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_mode_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_mode_t=NotReallyAType; fptools_cv_htype_sup_mode_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_mode_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_mode_t" >&5+echo "${ECHO_T}$fptools_cv_htype_mode_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_MODE_T $fptools_cv_htype_mode_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for off_t" >&5+echo $ECHO_N "checking Haskell type for off_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_off_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_off_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_off_t=NotReallyATypeCross; fptools_cv_htype_sup_off_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef off_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_off_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_off_t=NotReallyAType; fptools_cv_htype_sup_off_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_off_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_off_t" >&5+echo "${ECHO_T}$fptools_cv_htype_off_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_OFF_T $fptools_cv_htype_off_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for pid_t" >&5+echo $ECHO_N "checking Haskell type for pid_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_pid_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_pid_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_pid_t=NotReallyATypeCross; fptools_cv_htype_sup_pid_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef pid_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_pid_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_pid_t=NotReallyAType; fptools_cv_htype_sup_pid_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_pid_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_pid_t" >&5+echo "${ECHO_T}$fptools_cv_htype_pid_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_PID_T $fptools_cv_htype_pid_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for gid_t" >&5+echo $ECHO_N "checking Haskell type for gid_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_gid_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_gid_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_gid_t=NotReallyATypeCross; fptools_cv_htype_sup_gid_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef gid_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_gid_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_gid_t=NotReallyAType; fptools_cv_htype_sup_gid_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_gid_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_gid_t" >&5+echo "${ECHO_T}$fptools_cv_htype_gid_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_GID_T $fptools_cv_htype_gid_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for uid_t" >&5+echo $ECHO_N "checking Haskell type for uid_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_uid_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_uid_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_uid_t=NotReallyATypeCross; fptools_cv_htype_sup_uid_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef uid_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_uid_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_uid_t=NotReallyAType; fptools_cv_htype_sup_uid_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_uid_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_uid_t" >&5+echo "${ECHO_T}$fptools_cv_htype_uid_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UID_T $fptools_cv_htype_uid_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for cc_t" >&5+echo $ECHO_N "checking Haskell type for cc_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_cc_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_cc_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_cc_t=NotReallyATypeCross; fptools_cv_htype_sup_cc_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef cc_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_cc_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_cc_t=NotReallyAType; fptools_cv_htype_sup_cc_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_cc_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_cc_t" >&5+echo "${ECHO_T}$fptools_cv_htype_cc_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_CC_T $fptools_cv_htype_cc_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for speed_t" >&5+echo $ECHO_N "checking Haskell type for speed_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_speed_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_speed_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_speed_t=NotReallyATypeCross; fptools_cv_htype_sup_speed_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef speed_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_speed_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_speed_t=NotReallyAType; fptools_cv_htype_sup_speed_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_speed_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_speed_t" >&5+echo "${ECHO_T}$fptools_cv_htype_speed_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_SPEED_T $fptools_cv_htype_speed_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for tcflag_t" >&5+echo $ECHO_N "checking Haskell type for tcflag_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_tcflag_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_tcflag_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_tcflag_t=NotReallyATypeCross; fptools_cv_htype_sup_tcflag_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef tcflag_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_tcflag_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_tcflag_t=NotReallyAType; fptools_cv_htype_sup_tcflag_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_tcflag_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_tcflag_t" >&5+echo "${ECHO_T}$fptools_cv_htype_tcflag_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_TCFLAG_T $fptools_cv_htype_tcflag_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for nlink_t" >&5+echo $ECHO_N "checking Haskell type for nlink_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_nlink_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_nlink_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_nlink_t=NotReallyATypeCross; fptools_cv_htype_sup_nlink_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef nlink_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_nlink_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_nlink_t=NotReallyAType; fptools_cv_htype_sup_nlink_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_nlink_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_nlink_t" >&5+echo "${ECHO_T}$fptools_cv_htype_nlink_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_NLINK_T $fptools_cv_htype_nlink_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for ssize_t" >&5+echo $ECHO_N "checking Haskell type for ssize_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_ssize_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_ssize_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_ssize_t=NotReallyATypeCross; fptools_cv_htype_sup_ssize_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef ssize_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_ssize_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_ssize_t=NotReallyAType; fptools_cv_htype_sup_ssize_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_ssize_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_ssize_t" >&5+echo "${ECHO_T}$fptools_cv_htype_ssize_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_SSIZE_T $fptools_cv_htype_ssize_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for rlim_t" >&5+echo $ECHO_N "checking Haskell type for rlim_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_rlim_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_rlim_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_rlim_t=NotReallyATypeCross; fptools_cv_htype_sup_rlim_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef rlim_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_rlim_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_rlim_t=NotReallyAType; fptools_cv_htype_sup_rlim_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_rlim_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_rlim_t" >&5+echo "${ECHO_T}$fptools_cv_htype_rlim_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_RLIM_T $fptools_cv_htype_rlim_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for wint_t" >&5+echo $ECHO_N "checking Haskell type for wint_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_wint_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_wint_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_wint_t=NotReallyATypeCross; fptools_cv_htype_sup_wint_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef wint_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_wint_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_wint_t=NotReallyAType; fptools_cv_htype_sup_wint_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_wint_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_wint_t" >&5+echo "${ECHO_T}$fptools_cv_htype_wint_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_WINT_T $fptools_cv_htype_wint_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi+++{ echo "$as_me:$LINENO: checking Haskell type for intptr_t" >&5+echo $ECHO_N "checking Haskell type for intptr_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_intptr_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_intptr_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_intptr_t=NotReallyATypeCross; fptools_cv_htype_sup_intptr_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef intptr_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_intptr_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_intptr_t=NotReallyAType; fptools_cv_htype_sup_intptr_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_intptr_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_intptr_t" >&5+echo "${ECHO_T}$fptools_cv_htype_intptr_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_INTPTR_T $fptools_cv_htype_intptr_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for uintptr_t" >&5+echo $ECHO_N "checking Haskell type for uintptr_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_uintptr_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_uintptr_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_uintptr_t=NotReallyATypeCross; fptools_cv_htype_sup_uintptr_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef uintptr_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_uintptr_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_uintptr_t=NotReallyAType; fptools_cv_htype_sup_uintptr_t=no+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_uintptr_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_uintptr_t" >&5+echo "${ECHO_T}$fptools_cv_htype_uintptr_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UINTPTR_T $fptools_cv_htype_uintptr_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++# Workaround for OSes that don't have intmax_t and uintmax_t, e.g. OpenBSD.+if test "$ac_cv_type_long_long" = yes; then+  fptools_cv_default_htype_intmax=$fptools_cv_htype_long_long+  fptools_cv_default_htype_uintmax=$fptools_cv_htype_unsigned_long_long+else+  fptools_cv_default_htype_intmax=$fptools_cv_htype_long+  fptools_cv_default_htype_uintmax=$fptools_cv_htype_unsigned_long+fi+{ echo "$as_me:$LINENO: checking Haskell type for intmax_t" >&5+echo $ECHO_N "checking Haskell type for intmax_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_intmax_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_intmax_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_intmax_t=NotReallyATypeCross; fptools_cv_htype_sup_intmax_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef intmax_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_intmax_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_intmax_t=$fptools_cv_default_htype_intmax+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_intmax_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_intmax_t" >&5+echo "${ECHO_T}$fptools_cv_htype_intmax_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_INTMAX_T $fptools_cv_htype_intmax_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+fi++{ echo "$as_me:$LINENO: checking Haskell type for uintmax_t" >&5+echo $ECHO_N "checking Haskell type for uintmax_t... $ECHO_C" >&6; }+if test "${fptools_cv_htype_uintmax_t+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  fptools_cv_htype_sup_uintmax_t=yes+fp_check_htype_save_cppflags="$CPPFLAGS"+CPPFLAGS="$CPPFLAGS $X_CFLAGS"+if test "$cross_compiling" = yes; then+  fptools_cv_htype_uintmax_t=NotReallyATypeCross; fptools_cv_htype_sup_uintmax_t=no+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <stddef.h>++#if HAVE_SYS_TYPES_H+# include <sys/types.h>+#endif++#if HAVE_UNISTD_H+# include <unistd.h>+#endif++#if HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif++#if HAVE_FCNTL_H+# include <fcntl.h>+#endif++#if HAVE_SIGNAL_H+# include <signal.h>+#endif++#if HAVE_TIME_H+# include <time.h>+#endif++#if HAVE_TERMIOS_H+# include <termios.h>+#endif++#if HAVE_STRING_H+# include <string.h>+#endif++#if HAVE_CTYPE_H+# include <ctype.h>+#endif++#if HAVE_INTTYPES_H+# include <inttypes.h>+#else+# if HAVE_STDINT_H+#  include <stdint.h>+# endif+#endif++#if defined(HAVE_GL_GL_H)+# include <GL/gl.h>+#elif defined(HAVE_OPENGL_GL_H)+# include <OpenGL/gl.h>+#endif++#if defined(HAVE_AL_AL_H)+# include <AL/al.h>+#elif defined(HAVE_OPENAL_AL_H)+# include <OpenAL/al.h>+#endif++#if defined(HAVE_AL_ALC_H)+# include <AL/alc.h>+#elif defined(HAVE_OPENAL_ALC_H)+# include <OpenAL/alc.h>+#endif++#if HAVE_SYS_RESOURCE_H+# include <sys/resource.h>+#endif++typedef uintmax_t testing;++main() {+  FILE *f=fopen("conftestval", "w");+  if (!f) exit(1);+  if (((testing)((int)((testing)1.4))) == ((testing)1.4)) {+    fprintf(f, "%s%d\n",+           ((testing)(-1) < (testing)0) ? "Int" : "Word",+           sizeof(testing)*8);+  } else {+    fprintf(f,"%s\n",+           (sizeof(testing) >  sizeof(double)) ? "LDouble" :+           (sizeof(testing) == sizeof(double)) ? "Double"  : "Float");+  }+  fclose(f);+  exit(0);+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_htype_uintmax_t=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fptools_cv_htype_uintmax_t=$fptools_cv_default_htype_uintmax+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++CPPFLAGS="$fp_check_htype_save_cppflags"+fi+ if test "$fptools_cv_htype_sup_uintmax_t" = yes; then+  { echo "$as_me:$LINENO: result: $fptools_cv_htype_uintmax_t" >&5+echo "${ECHO_T}$fptools_cv_htype_uintmax_t" >&6; }++cat >>confdefs.h <<_ACEOF+#define HTYPE_UINTMAX_T $fptools_cv_htype_uintmax_t+_ACEOF++else+  { echo "$as_me:$LINENO: result: not supported" >&5+echo "${ECHO_T}not supported" >&6; }+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+do+as_fp_Cache=`echo "fp_cv_const_$fp_const_name" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking value of $fp_const_name" >&5+echo $ECHO_N "checking value of $fp_const_name... $ECHO_C" >&6; }+if { as_var=$as_fp_Cache; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  if test "$cross_compiling" = yes; then+  # Depending upon the size, compute the lo and hi bounds.+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <errno.h>++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) >= 0)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_lo=0 ac_mid=0+  while :; do+    cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <errno.h>++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) <= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=$ac_mid; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo=`expr $ac_mid + 1`+			if test $ac_lo -le $ac_mid; then+			  ac_lo= ac_hi=+			  break+			fi+			ac_mid=`expr 2 '*' $ac_mid + 1`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <errno.h>++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) < 0)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=-1 ac_mid=-1+  while :; do+    cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <errno.h>++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) >= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_lo=$ac_mid; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_hi=`expr '(' $ac_mid ')' - 1`+			if test $ac_mid -le $ac_hi; then+			  ac_lo= ac_hi=+			  break+			fi+			ac_mid=`expr 2 '*' $ac_mid`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo= ac_hi=+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+# Binary search between lo and hi bounds.+while test "x$ac_lo" != "x$ac_hi"; do+  ac_mid=`expr '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo`+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <errno.h>++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) <= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=$ac_mid+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo=`expr '(' $ac_mid ')' + 1`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+done+case $ac_lo in+?*) fp_check_const_result=$ac_lo;;+'') fp_check_const_result='-1' ;;+esac+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <stdio.h>+#include <errno.h>++static long int longval () { return $fp_const_name; }+static unsigned long int ulongval () { return $fp_const_name; }+#include <stdio.h>+#include <stdlib.h>+int+main ()+{++  FILE *f = fopen ("conftest.val", "w");+  if (! f)+    return 1;+  if (($fp_const_name) < 0)+    {+      long int i = longval ();+      if (i != ($fp_const_name))+	return 1;+      fprintf (f, "%ld\n", i);+    }+  else+    {+      unsigned long int i = ulongval ();+      if (i != ($fp_const_name))+	return 1;+      fprintf (f, "%lu\n", i);+    }+  return ferror (f) || fclose (f) != 0;++  ;+  return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fp_check_const_result=`cat conftest.val`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fp_check_const_result='-1'+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+rm -f conftest.val++eval "$as_fp_Cache=\$fp_check_const_result"+fi+ac_res=`eval echo '${'$as_fp_Cache'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+cat >>confdefs.h <<_ACEOF+#define `echo "CONST_$fp_const_name" | $as_tr_cpp` `eval echo '${'$as_fp_Cache'}'`+_ACEOF++done+++# we need SIGINT in TopHandler.lhs++for fp_const_name in SIGINT+do+as_fp_Cache=`echo "fp_cv_const_$fp_const_name" | $as_tr_sh`+{ echo "$as_me:$LINENO: checking value of $fp_const_name" >&5+echo $ECHO_N "checking value of $fp_const_name... $ECHO_C" >&6; }+if { as_var=$as_fp_Cache; eval "test \"\${$as_var+set}\" = set"; }; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  if test "$cross_compiling" = yes; then+  # Depending upon the size, compute the lo and hi bounds.+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++#if HAVE_SIGNAL_H+#include <signal.h>+#endif++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) >= 0)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_lo=0 ac_mid=0+  while :; do+    cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++#if HAVE_SIGNAL_H+#include <signal.h>+#endif++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) <= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=$ac_mid; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo=`expr $ac_mid + 1`+			if test $ac_lo -le $ac_mid; then+			  ac_lo= ac_hi=+			  break+			fi+			ac_mid=`expr 2 '*' $ac_mid + 1`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++#if HAVE_SIGNAL_H+#include <signal.h>+#endif++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) < 0)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=-1 ac_mid=-1+  while :; do+    cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++#if HAVE_SIGNAL_H+#include <signal.h>+#endif++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) >= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_lo=$ac_mid; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_hi=`expr '(' $ac_mid ')' - 1`+			if test $ac_mid -le $ac_hi; then+			  ac_lo= ac_hi=+			  break+			fi+			ac_mid=`expr 2 '*' $ac_mid`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo= ac_hi=+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+# Binary search between lo and hi bounds.+while test "x$ac_lo" != "x$ac_hi"; do+  ac_mid=`expr '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo`+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++#if HAVE_SIGNAL_H+#include <signal.h>+#endif++int+main ()+{+static int test_array [1 - 2 * !(($fp_const_name) <= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=$ac_mid+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo=`expr '(' $ac_mid ')' + 1`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+done+case $ac_lo in+?*) fp_check_const_result=$ac_lo;;+'') fp_check_const_result='-1' ;;+esac+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */++#if HAVE_SIGNAL_H+#include <signal.h>+#endif++static long int longval () { return $fp_const_name; }+static unsigned long int ulongval () { return $fp_const_name; }+#include <stdio.h>+#include <stdlib.h>+int+main ()+{++  FILE *f = fopen ("conftest.val", "w");+  if (! f)+    return 1;+  if (($fp_const_name) < 0)+    {+      long int i = longval ();+      if (i != ($fp_const_name))+	return 1;+      fprintf (f, "%ld\n", i);+    }+  else+    {+      unsigned long int i = ulongval ();+      if (i != ($fp_const_name))+	return 1;+      fprintf (f, "%lu\n", i);+    }+  return ferror (f) || fclose (f) != 0;++  ;+  return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fp_check_const_result=`cat conftest.val`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fp_check_const_result='-1'+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+rm -f conftest.val++eval "$as_fp_Cache=\$fp_check_const_result"+fi+ac_res=`eval echo '${'$as_fp_Cache'}'`+	       { echo "$as_me:$LINENO: result: $ac_res" >&5+echo "${ECHO_T}$ac_res" >&6; }+cat >>confdefs.h <<_ACEOF+#define `echo "CONST_$fp_const_name" | $as_tr_cpp` `eval echo '${'$as_fp_Cache'}'`+_ACEOF++done+++{ echo "$as_me:$LINENO: checking value of O_BINARY" >&5+echo $ECHO_N "checking value of O_BINARY... $ECHO_C" >&6; }+if test "${fp_cv_const_O_BINARY+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  if test "$cross_compiling" = yes; then+  # Depending upon the size, compute the lo and hi bounds.+cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <fcntl.h>++int+main ()+{+static int test_array [1 - 2 * !((O_BINARY) >= 0)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_lo=0 ac_mid=0+  while :; do+    cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <fcntl.h>++int+main ()+{+static int test_array [1 - 2 * !((O_BINARY) <= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=$ac_mid; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo=`expr $ac_mid + 1`+			if test $ac_lo -le $ac_mid; then+			  ac_lo= ac_hi=+			  break+			fi+			ac_mid=`expr 2 '*' $ac_mid + 1`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <fcntl.h>++int+main ()+{+static int test_array [1 - 2 * !((O_BINARY) < 0)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=-1 ac_mid=-1+  while :; do+    cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <fcntl.h>++int+main ()+{+static int test_array [1 - 2 * !((O_BINARY) >= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_lo=$ac_mid; break+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_hi=`expr '(' $ac_mid ')' - 1`+			if test $ac_mid -le $ac_hi; then+			  ac_lo= ac_hi=+			  break+			fi+			ac_mid=`expr 2 '*' $ac_mid`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+  done+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo= ac_hi=+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+# Binary search between lo and hi bounds.+while test "x$ac_lo" != "x$ac_hi"; do+  ac_mid=`expr '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo`+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <fcntl.h>++int+main ()+{+static int test_array [1 - 2 * !((O_BINARY) <= $ac_mid)];+test_array [0] = 0++  ;+  return 0;+}+_ACEOF+rm -f conftest.$ac_objext+if { (ac_try="$ac_compile"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_compile") 2>conftest.er1+  ac_status=$?+  grep -v '^ *+' conftest.er1 >conftest.err+  rm -f conftest.er1+  cat conftest.err >&5+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && {+	 test -z "$ac_c_werror_flag" ||+	 test ! -s conftest.err+       } && test -s conftest.$ac_objext; then+  ac_hi=$ac_mid+else+  echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++	ac_lo=`expr '(' $ac_mid ')' + 1`+fi++rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+done+case $ac_lo in+?*) fp_check_const_result=$ac_lo;;+'') fp_check_const_result=0 ;;+esac+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <fcntl.h>++static long int longval () { return O_BINARY; }+static unsigned long int ulongval () { return O_BINARY; }+#include <stdio.h>+#include <stdlib.h>+int+main ()+{++  FILE *f = fopen ("conftest.val", "w");+  if (! f)+    return 1;+  if ((O_BINARY) < 0)+    {+      long int i = longval ();+      if (i != (O_BINARY))+	return 1;+      fprintf (f, "%ld\n", i);+    }+  else+    {+      unsigned long int i = ulongval ();+      if (i != (O_BINARY))+	return 1;+      fprintf (f, "%lu\n", i);+    }+  return ferror (f) || fclose (f) != 0;++  ;+  return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fp_check_const_result=`cat conftest.val`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+fp_check_const_result=0+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+rm -f conftest.val++fp_cv_const_O_BINARY=$fp_check_const_result+fi+{ echo "$as_me:$LINENO: result: $fp_cv_const_O_BINARY" >&5+echo "${ECHO_T}$fp_cv_const_O_BINARY" >&6; }+cat >>confdefs.h <<_ACEOF+#define CONST_O_BINARY $fp_cv_const_O_BINARY+_ACEOF+++# Check for idiosyncracies in some mingw impls of directory handling.+{ echo "$as_me:$LINENO: checking what readdir sets errno to upon EOF" >&5+echo $ECHO_N "checking what readdir sets errno to upon EOF... $ECHO_C" >&6; }+if test "${fptools_cv_readdir_eof_errno+set}" = set; then+  echo $ECHO_N "(cached) $ECHO_C" >&6+else+  if test "$cross_compiling" = yes; then+  fptools_cv_readdir_eof_errno=0+else+  cat >conftest.$ac_ext <<_ACEOF+/* confdefs.h.  */+_ACEOF+cat confdefs.h >>conftest.$ac_ext+cat >>conftest.$ac_ext <<_ACEOF+/* end confdefs.h.  */+#include <dirent.h>+#include <stdio.h>+#include <errno.h>+int+main(argc, argv)+int argc;+char **argv;+{+  FILE *f=fopen("conftestval", "w");+#if defined(__MINGW32__)+  int fd = mkdir("testdir");+#else+  int fd = mkdir("testdir", 0666);+#endif+  DIR* dp;+  struct dirent* de;+  int err = 0;++  if (!f) return 1;+  if (fd == -1) {+     fprintf(stderr,"unable to create directory; quitting.\n");+     return 1;+  }+  close(fd);+  dp = opendir("testdir");+  if (!dp) {+     fprintf(stderr,"unable to browse directory; quitting.\n");+     rmdir("testdir");+     return 1;+  }++  /* the assumption here is that readdir() will only return NULL+   * due to reaching the end of the directory.+   */+  while (de = readdir(dp)) {+  	;+  }+  err = errno;+  fprintf(f,"%d", err);+  fclose(f);+  closedir(dp);+  rmdir("testdir");+  return 0;+}+_ACEOF+rm -f conftest$ac_exeext+if { (ac_try="$ac_link"+case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_link") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'+  { (case "(($ac_try" in+  *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+  *) ac_try_echo=$ac_try;;+esac+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5+  (eval "$ac_try") 2>&5+  ac_status=$?+  echo "$as_me:$LINENO: \$? = $ac_status" >&5+  (exit $ac_status); }; }; then+  fptools_cv_readdir_eof_errno=`cat conftestval`+else+  echo "$as_me: program exited with status $ac_status" >&5+echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++( exit $ac_status )+{ echo "$as_me:$LINENO: WARNING: failed to determine the errno value" >&5+echo "$as_me: WARNING: failed to determine the errno value" >&2;}+ fptools_cv_readdir_eof_errno=0+fi+rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext+fi+++fi+{ echo "$as_me:$LINENO: result: $fptools_cv_readdir_eof_errno" >&5+echo "${ECHO_T}$fptools_cv_readdir_eof_errno" >&6; }++cat >>confdefs.h <<_ACEOF+#define READDIR_ERRNO_EOF $fptools_cv_readdir_eof_errno+_ACEOF++++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_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5+echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;;+      esac+      case $ac_var in #(+      _ | IFS | as_nl) ;; #(+      *) $as_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+set}" = set || &/+     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+    test "x$cache_file" != "x/dev/null" &&+      { echo "$as_me:$LINENO: updating cache $cache_file" >&5+echo "$as_me: updating cache $cache_file" >&6;}+    cat confcache >$cache_file+  else+    { echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5+echo "$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=+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=`echo "$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.+  ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext"+  ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo'+done+LIBOBJS=$ac_libobjs++LTLIBOBJS=$ac_ltlibobjs++++: ${CONFIG_STATUS=./config.status}+ac_clean_files_save=$ac_clean_files+ac_clean_files="$ac_clean_files $CONFIG_STATUS"+{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5+echo "$as_me: creating $CONFIG_STATUS" >&6;}+cat >$CONFIG_STATUS <<_ACEOF+#! $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}+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+## --------------------- ##+## M4sh Initialization.  ##+## --------------------- ##++# Be more Bourne compatible+DUALCASE=1; export DUALCASE # for MKS sh+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then+  emulate sh+  NULLCMD=:+  # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which+  # is contrary to our usage.  Disable this feature.+  alias -g '${1+"$@"}'='"$@"'+  setopt NO_GLOB_SUBST+else+  case `(set -o) 2>/dev/null` in+  *posix*) set -o posix ;;+esac++fi+++++# PATH needs CR+# 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++# The user is always right.+if test "${PATH_SEPARATOR+set}" != set; then+  echo "#! /bin/sh" >conf$$.sh+  echo  "exit 0"   >>conf$$.sh+  chmod +x conf$$.sh+  if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then+    PATH_SEPARATOR=';'+  else+    PATH_SEPARATOR=:+  fi+  rm -f conf$$.sh+fi++# Support unset when possible.+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then+  as_unset=unset+else+  as_unset=false+fi+++# IFS+# We need space, tab and new line, in precisely that order.  Quoting is+# there to prevent editors from complaining about space-tab.+# (If _AS_PATH_WALK were called with IFS unset, it would disable word+# splitting by setting IFS to empty value.)+as_nl='+'+IFS=" ""	$as_nl"++# Find who we are.  Look in the path if we contain no directory separator.+case $0 in+  *[\\/]* ) as_myself=$0 ;;+  *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+  IFS=$as_save_IFS+  test -z "$as_dir" && as_dir=.+  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+  echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2+  { (exit 1); exit 1; }+fi++# Work around bugs in pre-3.0 UWIN ksh.+for as_var in ENV MAIL MAILPATH+do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+done+PS1='$ '+PS2='> '+PS4='+ '++# NLS nuisances.+for as_var in \+  LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \+  LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \+  LC_TELEPHONE LC_TIME+do+  if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then+    eval $as_var=C; export $as_var+  else+    ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var+  fi+done++# Required to use basename.+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+++# Name of the executable.+as_me=`$as_basename -- "$0" ||+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \+	 X"$0" : 'X\(//\)$' \| \+	 X"$0" : 'X\(/\)' \| . 2>/dev/null ||+echo X/"$0" |+    sed '/^.*\/\([^/][^/]*\)\/*$/{+	    s//\1/+	    q+	  }+	  /^X\/\(\/\/\)$/{+	    s//\1/+	    q+	  }+	  /^X\/\(\/\).*/{+	    s//\1/+	    q+	  }+	  s/.*/./; q'`++# CDPATH.+$as_unset CDPATH++++  as_lineno_1=$LINENO+  as_lineno_2=$LINENO+  test "x$as_lineno_1" != "x$as_lineno_2" &&+  test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || {++  # Create $as_me.lineno as a copy of $as_myself, but with $LINENO+  # uniformly replaced by the line number.  The first 'sed' inserts a+  # line-number line after each line using $LINENO; the second 'sed'+  # does the real work.  The second script uses 'N' to pair each+  # line-number line with the line containing $LINENO, and appends+  # trailing '-' during substitution so that $LINENO is not a special+  # case at line end.+  # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the+  # scripts with optimization help from Paolo Bonzini.  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" ||+    { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2+   { (exit 1); exit 1; }; }++  # 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+}+++if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then+  as_dirname=dirname+else+  as_dirname=false+fi++ECHO_C= ECHO_N= ECHO_T=+case `echo -n x` in+-n*)+  case `echo 'x\c'` in+  *c*) ECHO_T='	';;	# ECHO_T is single tab character.+  *)   ECHO_C='\c';;+  esac;;+*)+  ECHO_N='-n';;+esac++if expr a : '\(a\)' >/dev/null 2>&1 &&+   test "X`expr 00001 : '.*\(...\)'`" = X001; then+  as_expr=expr+else+  as_expr=false+fi++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+fi+echo >conf$$.file+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 -p'.+  ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||+    as_ln_s='cp -p'+elif ln conf$$.file conf$$ 2>/dev/null; then+  as_ln_s=ln+else+  as_ln_s='cp -p'+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=:+else+  test -d ./-p && rmdir ./-p+  as_mkdir_p=false+fi++if test -x / >/dev/null 2>&1; then+  as_test_x='test -x'+else+  if ls -dL / >/dev/null 2>&1; then+    as_ls_L_option=L+  else+    as_ls_L_option=+  fi+  as_test_x='+    eval sh -c '\''+      if test -d "$1"; then+        test -d "$1/.";+      else+	case $1 in+        -*)set "./$1";;+	esac;+	case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in+	???[sx]*):;;*)false;;esac;fi+    '\'' sh+  '+fi+as_executable_p=$as_test_x++# 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++# 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.61.  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++cat >>$CONFIG_STATUS <<_ACEOF+# Files that config.status was made for.+config_headers="$ac_config_headers"++_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+ac_cs_usage="\+\`$as_me' instantiates files from templates according to the+current configuration.++Usage: $0 [OPTIONS] [FILE]...++  -h, --help       print this help, then exit+  -V, --version    print version number and configuration settings, then exit+  -q, --quiet      do not print progress messages+  -d, --debug      don't remove temporary files+      --recheck    update $as_me by reconfiguring in the same conditions+  --header=FILE[:TEMPLATE]+		   instantiate the configuration header FILE++Configuration headers:+$config_headers++Report bugs to <bug-autoconf@gnu.org>."++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+ac_cs_version="\\+Haskell base package config.status 1.0+configured by $0, generated by GNU Autoconf 2.61,+  with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"++Copyright (C) 2006 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'+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF+# If no file are specified by the user, then we need to provide default+# value.  By we need to know if files were specified by the user.+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=$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 )+    echo "$ac_cs_version"; exit ;;+  --debug | --debu | --deb | --de | --d | -d )+    debug=: ;;+  --header | --heade | --head | --hea )+    $ac_shift+    CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg"+    ac_need_defaults=false;;+  --he | --h)+    # Conflict between --help and --header+    { echo "$as_me: error: ambiguous option: $1+Try \`$0 --help' for more information." >&2+   { (exit 1); exit 1; }; };;+  --help | --hel | -h )+    echo "$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.+  -*) { echo "$as_me: error: unrecognized option: $1+Try \`$0 --help' for more information." >&2+   { (exit 1); exit 1; }; } ;;++  *) ac_config_targets="$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+if \$ac_cs_recheck; then+  echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6+  CONFIG_SHELL=$SHELL+  export CONFIG_SHELL+  exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion+fi++_ACEOF+cat >>$CONFIG_STATUS <<\_ACEOF+exec 5>>config.log+{+  echo+  sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX+## Running $as_me. ##+_ASBOX+  echo "$ac_log"+} >&5++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF++# 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" ;;++  *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5+echo "$as_me: error: invalid argument: $ac_config_target" >&2;}+   { (exit 1); exit 1; }; };;+  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_HEADERS+set}" = set || 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=+  trap 'exit_status=$?+  { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status+' 0+  trap '{ (exit 1); exit 1; }' 1 2 13 15+}+# Create a (secure) tmp directory for tmp files.++{+  tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&+  test -n "$tmp" && test -d "$tmp"+}  ||+{+  tmp=./conf$$-$RANDOM+  (umask 077 && mkdir "$tmp")+} ||+{+   echo "$me: cannot create a temporary directory in ." >&2+   { (exit 1); exit 1; }+}+++for ac_tag in    :H $CONFIG_HEADERS+do+  case $ac_tag in+  :[FHLC]) ac_mode=$ac_tag; continue;;+  esac+  case $ac_mode$ac_tag in+  :[FHL]*:*);;+  :L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5+echo "$as_me: error: Invalid tag $ac_tag." >&2;}+   { (exit 1); exit 1; }; };;+  :[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="$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 ||+	   { { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5+echo "$as_me: error: cannot find input file: $ac_f" >&2;}+   { (exit 1); exit 1; }; };;+      esac+      ac_file_inputs="$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 "`IFS=:+	  echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure."+    if test x"$ac_file" != x-; then+      configure_input="$ac_file.  $configure_input"+      { echo "$as_me:$LINENO: creating $ac_file" >&5+echo "$as_me: creating $ac_file" >&6;}+    fi++    case $ac_tag in+    *:-:* | *:-) cat >"$tmp/stdin";;+    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 ||+echo 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"+  case $as_dir in #(+  -*) as_dir=./$as_dir;;+  esac+  test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {+    as_dirs=+    while :; do+      case $as_dir in #(+      *\'*) as_qdir=`echo "$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 ||+echo 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" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5+echo "$as_me: error: cannot create directory $as_dir" >&2;}+   { (exit 1); exit 1; }; }; }+  ac_builddir=.++case "$ac_dir" in+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;+*)+  ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`+  # A ".." for each directory in $ac_dir_suffix.+  ac_top_builddir_sub=`echo "$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++  :H)+  #+  # CONFIG_HEADER+  #+_ACEOF++# Transform confdefs.h into a sed script `conftest.defines', that+# substitutes the proper values into config.h.in to produce config.h.+rm -f conftest.defines conftest.tail+# First, append a space to every undef/define line, to ease matching.+echo 's/$/ /' >conftest.defines+# Then, protect against being on the right side of a sed subst, or in+# an unquoted here document, in config.status.  If some macros were+# called several times there might be several #defines for the same+# symbol, which is useless.  But do not sort them, since the last+# AC_DEFINE must be honored.+ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]*+# These sed commands are passed to sed as "A NAME B PARAMS C VALUE D", where+# NAME is the cpp macro being defined, VALUE is the value it is being given.+# PARAMS is the parameter list in the macro definition--in most cases, it's+# just an empty string.+ac_dA='s,^\\([	 #]*\\)[^	 ]*\\([	 ]*'+ac_dB='\\)[	 (].*,\\1define\\2'+ac_dC=' '+ac_dD=' ,'++uniq confdefs.h |+  sed -n '+	t rset+	:rset+	s/^[	 ]*#[	 ]*define[	 ][	 ]*//+	t ok+	d+	:ok+	s/[\\&,]/\\&/g+	s/^\('"$ac_word_re"'\)\(([^()]*)\)[	 ]*\(.*\)/ '"$ac_dA"'\1'"$ac_dB"'\2'"${ac_dC}"'\3'"$ac_dD"'/p+	s/^\('"$ac_word_re"'\)[	 ]*\(.*\)/'"$ac_dA"'\1'"$ac_dB$ac_dC"'\2'"$ac_dD"'/p+  ' >>conftest.defines++# Remove the space that was appended to ease matching.+# Then 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.+# (The regexp can be short, since the line contains either #define or #undef.)+echo 's/ $//+s,^[	 #]*u.*,/* & */,' >>conftest.defines++# Break up conftest.defines:+ac_max_sed_lines=50++# First sed command is:	 sed -f defines.sed $ac_file_inputs >"$tmp/out1"+# Second one is:	 sed -f defines.sed "$tmp/out1" >"$tmp/out2"+# Third one will be:	 sed -f defines.sed "$tmp/out2" >"$tmp/out1"+# et cetera.+ac_in='$ac_file_inputs'+ac_out='"$tmp/out1"'+ac_nxt='"$tmp/out2"'++while :+do+  # Write a here document:+    cat >>$CONFIG_STATUS <<_ACEOF+    # First, check the format of the line:+    cat >"\$tmp/defines.sed" <<\\CEOF+/^[	 ]*#[	 ]*undef[	 ][	 ]*$ac_word_re[	 ]*\$/b def+/^[	 ]*#[	 ]*define[	 ][	 ]*$ac_word_re[(	 ]/b def+b+:def+_ACEOF+  sed ${ac_max_sed_lines}q conftest.defines >>$CONFIG_STATUS+  echo 'CEOF+    sed -f "$tmp/defines.sed"' "$ac_in >$ac_out" >>$CONFIG_STATUS+  ac_in=$ac_out; ac_out=$ac_nxt; ac_nxt=$ac_in+  sed 1,${ac_max_sed_lines}d conftest.defines >conftest.tail+  grep . conftest.tail >/dev/null || break+  rm -f conftest.defines+  mv conftest.tail conftest.defines+done+rm -f conftest.defines conftest.tail++echo "ac_result=$ac_in" >>$CONFIG_STATUS+cat >>$CONFIG_STATUS <<\_ACEOF+  if test x"$ac_file" != x-; then+    echo "/* $configure_input  */" >"$tmp/config.h"+    cat "$ac_result" >>"$tmp/config.h"+    if diff $ac_file "$tmp/config.h" >/dev/null 2>&1; then+      { echo "$as_me:$LINENO: $ac_file is unchanged" >&5+echo "$as_me: $ac_file is unchanged" >&6;}+    else+      rm -f $ac_file+      mv "$tmp/config.h" $ac_file+    fi+  else+    echo "/* $configure_input  */"+    cat "$ac_result"+  fi+  rm -f "$tmp/out12"+ ;;+++  esac++done # for ac_tag+++{ (exit 0); exit 0; }+_ACEOF+chmod +x $CONFIG_STATUS+ac_clean_files=$ac_clean_files_save+++# 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 || { (exit 1); exit 1; }+fi+
+ configure.ac view
@@ -0,0 +1,105 @@+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])++AC_ARG_WITH([cc],+            [C compiler],+            [CC=$withval])+AC_PROG_CC()++# do we have long longs?+AC_CHECK_TYPES([long long])++dnl ** determine whether or not const works+AC_C_CONST++dnl ** check for full ANSI header (.h) files+AC_HEADER_STDC++# check for specific header (.h) files that we are interested in+AC_CHECK_HEADERS([ctype.h dirent.h errno.h fcntl.h inttypes.h limits.h signal.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])++# 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 emtpy 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 readdir_r])+AC_CHECK_FUNCS([getclock getrusage times])+AC_CHECK_FUNCS([_chsize ftruncate])++# 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(float)+FPTOOLS_CHECK_HTYPE(double)+FPTOOLS_CHECK_HTYPE(ptrdiff_t)+FPTOOLS_CHECK_HTYPE(size_t)+FPTOOLS_CHECK_HTYPE(wchar_t)+# Int32 is a HACK for non-ISO C compilers+FPTOOLS_CHECK_HTYPE(sig_atomic_t, Int32)+FPTOOLS_CHECK_HTYPE(clock_t)+FPTOOLS_CHECK_HTYPE(time_t)+FPTOOLS_CHECK_HTYPE(dev_t, Word32)+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(wint_t)++FPTOOLS_CHECK_HTYPE(intptr_t)+FPTOOLS_CHECK_HTYPE(uintptr_t)+# Workaround for OSes that don't have intmax_t and uintmax_t, e.g. OpenBSD.+if test "$ac_cv_type_long_long" = yes; then+  fptools_cv_default_htype_intmax=$fptools_cv_htype_long_long+  fptools_cv_default_htype_uintmax=$fptools_cv_htype_unsigned_long_long+else+  fptools_cv_default_htype_intmax=$fptools_cv_htype_long+  fptools_cv_default_htype_uintmax=$fptools_cv_htype_unsigned_long+fi+FPTOOLS_CHECK_HTYPE(intmax_t, $fptools_cv_default_htype_intmax)+FPTOOLS_CHECK_HTYPE(uintmax_t, $fptools_cv_default_htype_uintmax)++# 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], [#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])++# Check for idiosyncracies in some mingw impls of directory handling.+FP_READDIR_EOF_ERRNO++AC_OUTPUT
+ include/CTypes.h view
@@ -0,0 +1,211 @@+{- --------------------------------------------------------------------------+// Dirty CPP hackery for CTypes/CTypesISO+//+// (c) The FFI task force, 2000+// --------------------------------------------------------------------------+-}++#ifndef CTYPES__H+#define CTYPES__H++#include "Typeable.h"++{-+// 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.+-}++--  // A hacked version for GHC follows the Haskell 98 version...+#ifndef __GLASGOW_HASKELL__++#define ARITHMETIC_TYPE(T,C,S,B) \+newtype T = T B deriving (Eq, Ord) ; \+INSTANCE_NUM(T) ; \+INSTANCE_REAL(T) ; \+INSTANCE_READ(T,B) ; \+INSTANCE_SHOW(T,B) ; \+INSTANCE_ENUM(T) ; \+INSTANCE_STORABLE(T) ; \+INSTANCE_TYPEABLE0(T,C,S) ;++#define INTEGRAL_TYPE(T,C,S,B) \+ARITHMETIC_TYPE(T,C,S,B) ; \+INSTANCE_BOUNDED(T) ; \+INSTANCE_INTEGRAL(T) ; \+INSTANCE_BITS(T)++#define FLOATING_TYPE(T,C,S,B) \+ARITHMETIC_TYPE(T,C,S,B) ; \+INSTANCE_FRACTIONAL(T) ; \+INSTANCE_FLOATING(T) ; \+INSTANCE_REALFRAC(T) ; \+INSTANCE_REALFLOAT(T)++#ifndef __GLASGOW_HASKELL__+#define fakeMap map+#endif++#define INSTANCE_READ(T,B) \+instance Read T where { \+   readsPrec p s = fakeMap (\(x, t) -> (T x, t)) (readsPrec p s) }++#define INSTANCE_SHOW(T,B) \+instance Show T where { \+   showsPrec p (T x) = showsPrec p x }++#define INSTANCE_NUM(T) \+instance Num T where { \+   (T i) + (T j) = T (i + j) ; \+   (T i) - (T j) = T (i - j) ; \+   (T i) * (T j) = T (i * j) ; \+   negate  (T i) = T (negate i) ; \+   abs     (T i) = T (abs    i) ; \+   signum  (T i) = T (signum i) ; \+   fromInteger x = T (fromInteger x) }++#define INSTANCE_BOUNDED(T) \+instance Bounded T where { \+   minBound = T minBound ; \+   maxBound = T maxBound }++#define INSTANCE_ENUM(T) \+instance Enum T where { \+   succ           (T i)             = T (succ i) ; \+   pred           (T i)             = T (pred i) ; \+   toEnum               x           = T (toEnum x) ; \+   fromEnum       (T i)             = fromEnum i ; \+   enumFrom       (T i)             = fakeMap T (enumFrom i) ; \+   enumFromThen   (T i) (T j)       = fakeMap T (enumFromThen i j) ; \+   enumFromTo     (T i) (T j)       = fakeMap T (enumFromTo i j) ; \+   enumFromThenTo (T i) (T j) (T k) = fakeMap T (enumFromThenTo i j k) }++#define INSTANCE_REAL(T) \+instance Real T where { \+   toRational (T i) = toRational i }++#define INSTANCE_INTEGRAL(T) \+instance Integral T where { \+   (T i) `quot`    (T j) = T (i `quot` j) ; \+   (T i) `rem`     (T j) = T (i `rem`  j) ; \+   (T i) `div`     (T j) = T (i `div`  j) ; \+   (T i) `mod`     (T j) = T (i `mod`  j) ; \+   (T i) `quotRem` (T j) = let (q,r) = i `quotRem` j in (T q, T r) ; \+   (T i) `divMod`  (T j) = let (d,m) = i `divMod`  j in (T d, T m) ; \+   toInteger (T i)       = toInteger i }++#define INSTANCE_BITS(T) \+instance Bits T where { \+  (T x) .&.     (T y)   = T (x .&.   y) ; \+  (T x) .|.     (T y)   = T (x .|.   y) ; \+  (T x) `xor`   (T y)   = T (x `xor` y) ; \+  complement    (T x)   = T (complement x) ; \+  shift         (T x) n = T (shift x n) ; \+  rotate        (T x) n = T (rotate x n) ; \+  bit                 n = T (bit n) ; \+  setBit        (T x) n = T (setBit x n) ; \+  clearBit      (T x) n = T (clearBit x n) ; \+  complementBit (T x) n = T (complementBit x n) ; \+  testBit       (T x) n = testBit x n ; \+  bitSize       (T x)   = bitSize x ; \+  isSigned      (T x)   = isSigned x }++#define INSTANCE_FRACTIONAL(T) \+instance Fractional T where { \+   (T x) / (T y)  = T (x / y) ; \+   recip   (T x)  = T (recip x) ; \+   fromRational r = T (fromRational r) }++#define INSTANCE_FLOATING(T) \+instance Floating T where { \+   pi                    = pi ; \+   exp   (T x)           = T (exp   x) ; \+   log   (T x)           = T (log   x) ; \+   sqrt  (T x)           = T (sqrt  x) ; \+   (T x) **        (T y) = T (x ** y) ; \+   (T x) `logBase` (T y) = T (x `logBase` y) ; \+   sin   (T x)           = T (sin   x) ; \+   cos   (T x)           = T (cos   x) ; \+   tan   (T x)           = T (tan   x) ; \+   asin  (T x)           = T (asin  x) ; \+   acos  (T x)           = T (acos  x) ; \+   atan  (T x)           = T (atan  x) ; \+   sinh  (T x)           = T (sinh  x) ; \+   cosh  (T x)           = T (cosh  x) ; \+   tanh  (T x)           = T (tanh  x) ; \+   asinh (T x)           = T (asinh x) ; \+   acosh (T x)           = T (acosh x) ; \+   atanh (T x)           = T (atanh x) }++#define INSTANCE_REALFRAC(T) \+instance RealFrac T where { \+   properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \+   truncate (T x) = truncate x ; \+   round    (T x) = round x ; \+   ceiling  (T x) = ceiling x ; \+   floor    (T x) = floor x }++#define INSTANCE_REALFLOAT(T) \+instance RealFloat T where { \+   floatRadix     (T x) = floatRadix x ; \+   floatDigits    (T x) = floatDigits x ; \+   floatRange     (T x) = floatRange x ; \+   decodeFloat    (T x) = decodeFloat x ; \+   encodeFloat m n      = T (encodeFloat m n) ; \+   exponent       (T x) = exponent x ; \+   significand    (T x) = T (significand  x) ; \+   scaleFloat n   (T x) = T (scaleFloat n x) ; \+   isNaN          (T x) = isNaN x ; \+   isInfinite     (T x) = isInfinite x ; \+   isDenormalized (T x) = isDenormalized x ; \+   isNegativeZero (T x) = isNegativeZero x ; \+   isIEEE         (T x) = isIEEE x ; \+   (T x) `atan2`  (T y) = T (x `atan2` y) }++#define INSTANCE_STORABLE(T) \+instance Storable T where { \+   sizeOf    (T x)       = sizeOf x ; \+   alignment (T x)       = alignment x ; \+   peekElemOff a i       = liftM T (peekElemOff (castPtr a) i) ; \+   pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x }++#else /* __GLASGOW_HASKELL__ */++--  // 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+#define FLOATING_CLASSES Fractional,Floating,RealFrac,RealFloat++#define ARITHMETIC_TYPE(T,C,S,B) \+newtype T = T B deriving (ARITHMETIC_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;++#define INTEGRAL_TYPE(T,C,S,B) \+newtype T = T B deriving (ARITHMETIC_CLASSES, INTEGRAL_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;++#define FLOATING_TYPE(T,C,S,B) \+newtype T = T B deriving (ARITHMETIC_CLASSES, FLOATING_CLASSES); \+INSTANCE_READ(T,B); \+INSTANCE_SHOW(T,B); \+INSTANCE_TYPEABLE0(T,C,S) ;++#define INSTANCE_READ(T,B) \+instance Read T where { \+   readsPrec            = unsafeCoerce# (readsPrec :: Int -> ReadS B); \+   readList             = unsafeCoerce# (readList  :: ReadS [B]); }++#define INSTANCE_SHOW(T,B) \+instance Show T where { \+   showsPrec            = unsafeCoerce# (showsPrec :: Int -> B -> ShowS); \+   show                 = unsafeCoerce# (show :: B -> String); \+   showList             = unsafeCoerce# (showList :: [B] -> ShowS); }++#endif /* __GLASGOW_HASKELL__ */++#endif
+ include/HsBase.h view
@@ -0,0 +1,738 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The University of Glasgow 2001-2004+ *+ * Definitions for package `base' which are visible in Haskell land.+ *+ * ---------------------------------------------------------------------------*/++#ifndef __HSBASE_H__+#define __HSBASE_H__++#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 <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_DIRENT_H+#include <dirent.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+#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(__MINGW32__)+#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(__MINGW32__) && !defined(irix_HOST_OS)+# 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 "dirUtils.h"+#include "WCsubst.h"++#if defined(__MINGW32__)+/* in Win32Utils.c */+extern void maperrno (void);+extern HsWord64 getUSecOfDay(void);+#endif++#if defined(__MINGW32__)+#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, int write, int msecs, int isSock);++/* in Signals.c */+extern HsInt nocldstop;++/* -----------------------------------------------------------------------------+   64-bit operations, defined in longlong.c+   -------------------------------------------------------------------------- */++#ifdef SUPPORT_LONG_LONGS++HsBool hs_gtWord64 (HsWord64, HsWord64);+HsBool hs_geWord64 (HsWord64, HsWord64);+HsBool hs_eqWord64 (HsWord64, HsWord64);+HsBool hs_neWord64 (HsWord64, HsWord64);+HsBool hs_ltWord64 (HsWord64, HsWord64);+HsBool hs_leWord64 (HsWord64, HsWord64);++HsBool hs_gtInt64 (HsInt64, HsInt64);+HsBool hs_geInt64 (HsInt64, HsInt64);+HsBool hs_eqInt64 (HsInt64, HsInt64);+HsBool hs_neInt64 (HsInt64, HsInt64);+HsBool hs_ltInt64 (HsInt64, HsInt64);+HsBool hs_leInt64 (HsInt64, HsInt64);++HsWord64 hs_remWord64  (HsWord64, HsWord64);+HsWord64 hs_quotWord64 (HsWord64, HsWord64);++HsInt64 hs_remInt64    (HsInt64, HsInt64);+HsInt64 hs_quotInt64   (HsInt64, HsInt64);+HsInt64 hs_negateInt64 (HsInt64);+HsInt64 hs_plusInt64   (HsInt64, HsInt64);+HsInt64 hs_minusInt64  (HsInt64, HsInt64);+HsInt64 hs_timesInt64  (HsInt64, HsInt64);++HsWord64 hs_and64  (HsWord64, HsWord64);+HsWord64 hs_or64   (HsWord64, HsWord64);+HsWord64 hs_xor64  (HsWord64, HsWord64);+HsWord64 hs_not64  (HsWord64);++HsWord64 hs_uncheckedShiftL64   (HsWord64, HsInt);+HsWord64 hs_uncheckedShiftRL64  (HsWord64, HsInt);+HsInt64  hs_uncheckedIShiftL64  (HsInt64, HsInt);+HsInt64  hs_uncheckedIShiftRA64 (HsInt64, HsInt);+HsInt64  hs_uncheckedIShiftRL64 (HsInt64, HsInt);++HsInt64  hs_intToInt64    (HsInt);+HsInt    hs_int64ToInt    (HsInt64);+HsWord64 hs_int64ToWord64 (HsInt64);+HsWord64 hs_wordToWord64  (HsWord);+HsWord   hs_word64ToWord  (HsWord64);+HsInt64  hs_word64ToInt64 (HsWord64);++HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da);+HsInt64  hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da);++#endif /* SUPPORT_LONG_LONGS */++/* -----------------------------------------------------------------------------+   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.+   -------------------------------------------------------------------------- */++#ifndef 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; }++#if !defined(_MSC_VER)+INLINE int __hscore_s_isreg(mode_t m)  { return S_ISREG(m);  }+INLINE int __hscore_s_isdir(mode_t m)  { return S_ISDIR(m);  }+INLINE int __hscore_s_isfifo(mode_t m) { return S_ISFIFO(m); }+INLINE int __hscore_s_isblk(mode_t m)  { return S_ISBLK(m);  }+INLINE int __hscore_s_ischr(mode_t m)  { return S_ISCHR(m);  }+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+INLINE int __hscore_s_issock(mode_t m) { return S_ISSOCK(m); }+#endif+#endif++#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)+INLINE int+__hscore_sigemptyset( sigset_t *set )+{ return sigemptyset(set); }++INLINE int+__hscore_sigfillset( sigset_t *set )+{ return sigfillset(set); }++INLINE int+__hscore_sigaddset( sigset_t * set, int s )+{ return sigaddset(set,s); }++INLINE int+__hscore_sigdelset( sigset_t * set, int s )+{ return sigdelset(set,s); }++INLINE int+__hscore_sigismember( sigset_t * set, int s )+{ return sigismember(set,s); }+#endif++INLINE void *+__hscore_memcpy_dst_off( char *dst, int dst_off, char *src, size_t sz )+{ return memcpy(dst+dst_off, src, sz); }++INLINE void *+__hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz )+{ return memcpy(dst, src+src_off, sz); }++INLINE HsBool+__hscore_supportsTextMode()+{+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+  return HS_BOOL_FALSE;+#else+  return HS_BOOL_TRUE;+#endif+}++INLINE HsInt+__hscore_bufsiz()+{+  return BUFSIZ;+}++INLINE int+__hscore_seek_cur()+{+  return SEEK_CUR;+}++INLINE int+__hscore_o_binary()+{+#if defined(_MSC_VER)+  return O_BINARY;+#else+  return CONST_O_BINARY;+#endif+}++INLINE int+__hscore_o_rdonly()+{+#ifdef O_RDONLY+  return O_RDONLY;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_wronly( void )+{+#ifdef O_WRONLY+  return O_WRONLY;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_rdwr( void )+{+#ifdef O_RDWR+  return O_RDWR;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_append( void )+{+#ifdef O_APPEND+  return O_APPEND;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_creat( void )+{+#ifdef O_CREAT+  return O_CREAT;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_excl( void )+{+#ifdef O_EXCL+  return O_EXCL;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_trunc( void )+{+#ifdef O_TRUNC+  return O_TRUNC;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_noctty( void )+{+#ifdef O_NOCTTY+  return O_NOCTTY;+#else+  return 0;+#endif+}++INLINE int+__hscore_o_nonblock( void )+{+#ifdef O_NONBLOCK+  return O_NONBLOCK;+#else+  return 0;+#endif+}++INLINE int+__hscore_seek_set( void )+{+  return SEEK_SET;+}++INLINE int+__hscore_seek_end( void )+{+  return SEEK_END;+}++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(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+  return setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT);+#else+  return 0;+#endif+}++#if __GLASGOW_HASKELL__++INLINE int+__hscore_PrelHandle_write( int fd, void *ptr, HsInt off, int sz )+{+  return write(fd,(char *)ptr + off, sz);+}++INLINE int+__hscore_PrelHandle_read( int fd, void *ptr, HsInt off, int sz )+{+  return read(fd,(char *)ptr + off, sz);++}++#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+INLINE int+__hscore_PrelHandle_send( int fd, void *ptr, HsInt off, int sz )+{+    return send(fd,(char *)ptr + off, sz, 0);+}++INLINE int+__hscore_PrelHandle_recv( int fd, void *ptr, HsInt off, int sz )+{+    return recv(fd,(char *)ptr + off, sz, 0);+}+#endif++#endif /* __GLASGOW_HASKELL__ */++INLINE int+__hscore_mkdir( char *pathName, int mode )+{+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)+  return mkdir(pathName);+#else+  return mkdir(pathName,mode);+#endif+}++INLINE int+__hscore_lstat( const char *fname, struct stat *st )+{+#if HAVE_LSTAT+  return lstat(fname, st);+#else+  return stat(fname, st);+#endif+}++INLINE char *+__hscore_d_name( struct dirent* d )+{+  return (d->d_name);+}++INLINE int+__hscore_end_of_dir( void )+{+  return READDIR_ERRNO_EOF;+}++INLINE void+__hscore_free_dirent(struct dirent *dEnt)+{+#if HAVE_READDIR_R+  free(dEnt);+#endif+}++#if defined(__MINGW32__)+// 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.+#define stat(file,buf)       _stati64(file,buf)+#define fstat(fd,buf)        _fstati64(fd,buf)+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 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 )+{+#ifndef __MINGW32__+  return sizeof(struct termios);+#else+  return 0;+#endif+}+#endif++#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)+INLINE HsInt+__hscore_sizeof_sigset_t( void )+{+  return sizeof(sigset_t);+}+#endif++INLINE int+__hscore_echo( void )+{+#ifdef ECHO+  return ECHO;+#else+  return 0;+#endif++}++INLINE int+__hscore_tcsanow( void )+{+#ifdef TCSANOW+  return TCSANOW;+#else+  return 0;+#endif++}++INLINE int+__hscore_icanon( void )+{+#ifdef ICANON+  return ICANON;+#else+  return 0;+#endif+}++INLINE int __hscore_vmin( void )+{+#ifdef VMIN+  return VMIN;+#else+  return 0;+#endif+}++INLINE int __hscore_vtime( void )+{+#ifdef VTIME+  return VTIME;+#else+  return 0;+#endif+}++INLINE int __hscore_sigttou( void )+{+#ifdef SIGTTOU+  return SIGTTOU;+#else+  return 0;+#endif+}++INLINE int __hscore_sig_block( void )+{+#ifdef SIG_BLOCK+  return SIG_BLOCK;+#else+  return 0;+#endif+}++INLINE int __hscore_sig_setmask( void )+{+#ifdef SIG_SETMASK+  return SIG_SETMASK;+#else+  return 0;+#endif+}++INLINE int+__hscore_f_getfl( void )+{+#ifdef F_GETFL+  return F_GETFL;+#else+  return 0;+#endif+}++INLINE int+__hscore_f_setfl( void )+{+#ifdef F_SETFL+  return F_SETFL;+#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);++INLINE int __hscore_hs_fileno (FILE *f) { return fileno (f); }++INLINE int __hscore_open(char *file, int how, mode_t mode) {+#ifdef __MINGW32__+	if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))+	  return _sopen(file,how,_SH_DENYRW,mode);+	else+	  return _sopen(file,how,_SH_DENYWR,mode);+#else+	return open(file,how,mode);+#endif+}++// These are wrapped because on some OSs (eg. Linux) they are+// macros which redirect to the 64-bit-off_t versions when large file+// support is enabled.+//+#if defined(__MINGW32__)+INLINE off64_t __hscore_lseek(int fd, off64_t off, int whence) {+	return (_lseeki64(fd,off,whence));+}+#else+INLINE off_t __hscore_lseek(int fd, off_t off, int whence) {+	return (lseek(fd,off,whence));+}+#endif++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));+}++// select-related stuff++#if !defined(__MINGW32__)+INLINE int  hsFD_SETSIZE(void) { return FD_SETSIZE; }+INLINE int  hsFD_ISSET(int fd, fd_set *fds) { return FD_ISSET(fd, fds); }+INLINE void hsFD_SET(int fd, fd_set *fds) { FD_SET(fd, fds); }+INLINE HsInt sizeof_fd_set(void) { return sizeof(fd_set); }+extern void hsFD_ZERO(fd_set *fds);+#endif++// gettimeofday()-related++#if !defined(__MINGW32__)++INLINE HsInt sizeofTimeVal(void) { return sizeof(struct timeval); }++INLINE HsWord64 getUSecOfDay(void)+{+    struct timeval tv;+    gettimeofday(&tv, (struct timezone *) NULL);+    // Don't forget to cast *before* doing the arithmetic, otherwise+    // the arithmetic happens at the type of tv_sec, which is probably+    // only 'int'.+    return ((HsWord64)tv.tv_sec * 1000000 + (HsWord64)tv.tv_usec);+}++INLINE void setTimevalTicks(struct timeval *p, HsWord64 usecs)+{+    p->tv_sec  = usecs / 1000000;+    p->tv_usec = usecs % 1000000;+}+#endif /* !defined(__MINGW32__) */++/* ToDo: write a feature test that doesn't assume 'environ' to+ *    be in scope at link-time. */+extern char** environ;+INLINE char **__hscore_environ() { return environ; }++/* 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);++#endif /* __HSBASE_H__ */+
+ include/HsBaseConfig.h view
@@ -0,0 +1,563 @@+/* include/HsBaseConfig.h.  Generated from HsBaseConfig.h.in by configure.  */+/* include/HsBaseConfig.h.in.  Generated from configure.ac by autoheader.  */++/* The value of E2BIG. */+#define CONST_E2BIG 7++/* The value of EACCES. */+#define CONST_EACCES 13++/* The value of EADDRINUSE. */+#define CONST_EADDRINUSE 98++/* The value of EADDRNOTAVAIL. */+#define CONST_EADDRNOTAVAIL 99++/* The value of EADV. */+#define CONST_EADV 68++/* The value of EAFNOSUPPORT. */+#define CONST_EAFNOSUPPORT 97++/* The value of EAGAIN. */+#define CONST_EAGAIN 11++/* The value of EALREADY. */+#define CONST_EALREADY 114++/* The value of EBADF. */+#define CONST_EBADF 9++/* The value of EBADMSG. */+#define CONST_EBADMSG 74++/* The value of EBADRPC. */+#define CONST_EBADRPC -1++/* The value of EBUSY. */+#define CONST_EBUSY 16++/* The value of ECHILD. */+#define CONST_ECHILD 10++/* The value of ECOMM. */+#define CONST_ECOMM 70++/* The value of ECONNABORTED. */+#define CONST_ECONNABORTED 103++/* The value of ECONNREFUSED. */+#define CONST_ECONNREFUSED 111++/* The value of ECONNRESET. */+#define CONST_ECONNRESET 104++/* The value of EDEADLK. */+#define CONST_EDEADLK 35++/* The value of EDESTADDRREQ. */+#define CONST_EDESTADDRREQ 89++/* The value of EDIRTY. */+#define CONST_EDIRTY -1++/* The value of EDOM. */+#define CONST_EDOM 33++/* The value of EDQUOT. */+#define CONST_EDQUOT 122++/* The value of EEXIST. */+#define CONST_EEXIST 17++/* The value of EFAULT. */+#define CONST_EFAULT 14++/* The value of EFBIG. */+#define CONST_EFBIG 27++/* The value of EFTYPE. */+#define CONST_EFTYPE -1++/* The value of EHOSTDOWN. */+#define CONST_EHOSTDOWN 112++/* The value of EHOSTUNREACH. */+#define CONST_EHOSTUNREACH 113++/* The value of EIDRM. */+#define CONST_EIDRM 43++/* The value of EILSEQ. */+#define CONST_EILSEQ 84++/* The value of EINPROGRESS. */+#define CONST_EINPROGRESS 115++/* The value of EINTR. */+#define CONST_EINTR 4++/* The value of EINVAL. */+#define CONST_EINVAL 22++/* The value of EIO. */+#define CONST_EIO 5++/* The value of EISCONN. */+#define CONST_EISCONN 106++/* The value of EISDIR. */+#define CONST_EISDIR 21++/* The value of ELOOP. */+#define CONST_ELOOP 40++/* The value of EMFILE. */+#define CONST_EMFILE 24++/* The value of EMLINK. */+#define CONST_EMLINK 31++/* The value of EMSGSIZE. */+#define CONST_EMSGSIZE 90++/* The value of EMULTIHOP. */+#define CONST_EMULTIHOP 72++/* The value of ENAMETOOLONG. */+#define CONST_ENAMETOOLONG 36++/* The value of ENETDOWN. */+#define CONST_ENETDOWN 100++/* The value of ENETRESET. */+#define CONST_ENETRESET 102++/* The value of ENETUNREACH. */+#define CONST_ENETUNREACH 101++/* The value of ENFILE. */+#define CONST_ENFILE 23++/* The value of ENOBUFS. */+#define CONST_ENOBUFS 105++/* The value of ENOCIGAR. */+#define CONST_ENOCIGAR -1++/* The value of ENODATA. */+#define CONST_ENODATA 61++/* The value of ENODEV. */+#define CONST_ENODEV 19++/* The value of ENOENT. */+#define CONST_ENOENT 2++/* The value of ENOEXEC. */+#define CONST_ENOEXEC 8++/* The value of ENOLCK. */+#define CONST_ENOLCK 37++/* The value of ENOLINK. */+#define CONST_ENOLINK 67++/* The value of ENOMEM. */+#define CONST_ENOMEM 12++/* The value of ENOMSG. */+#define CONST_ENOMSG 42++/* The value of ENONET. */+#define CONST_ENONET 64++/* The value of ENOPROTOOPT. */+#define CONST_ENOPROTOOPT 92++/* The value of ENOSPC. */+#define CONST_ENOSPC 28++/* The value of ENOSR. */+#define CONST_ENOSR 63++/* The value of ENOSTR. */+#define CONST_ENOSTR 60++/* The value of ENOSYS. */+#define CONST_ENOSYS 38++/* The value of ENOTBLK. */+#define CONST_ENOTBLK 15++/* The value of ENOTCONN. */+#define CONST_ENOTCONN 107++/* The value of ENOTDIR. */+#define CONST_ENOTDIR 20++/* The value of ENOTEMPTY. */+#define CONST_ENOTEMPTY 39++/* The value of ENOTSOCK. */+#define CONST_ENOTSOCK 88++/* The value of ENOTTY. */+#define CONST_ENOTTY 25++/* The value of ENXIO. */+#define CONST_ENXIO 6++/* The value of EOPNOTSUPP. */+#define CONST_EOPNOTSUPP 95++/* The value of EPERM. */+#define CONST_EPERM 1++/* The value of EPFNOSUPPORT. */+#define CONST_EPFNOSUPPORT 96++/* The value of EPIPE. */+#define CONST_EPIPE 32++/* The value of EPROCLIM. */+#define CONST_EPROCLIM -1++/* The value of EPROCUNAVAIL. */+#define CONST_EPROCUNAVAIL -1++/* The value of EPROGMISMATCH. */+#define CONST_EPROGMISMATCH -1++/* The value of EPROGUNAVAIL. */+#define CONST_EPROGUNAVAIL -1++/* The value of EPROTO. */+#define CONST_EPROTO 71++/* The value of EPROTONOSUPPORT. */+#define CONST_EPROTONOSUPPORT 93++/* The value of EPROTOTYPE. */+#define CONST_EPROTOTYPE 91++/* The value of ERANGE. */+#define CONST_ERANGE 34++/* The value of EREMCHG. */+#define CONST_EREMCHG 78++/* The value of EREMOTE. */+#define CONST_EREMOTE 66++/* The value of EROFS. */+#define CONST_EROFS 30++/* The value of ERPCMISMATCH. */+#define CONST_ERPCMISMATCH -1++/* The value of ERREMOTE. */+#define CONST_ERREMOTE -1++/* The value of ESHUTDOWN. */+#define CONST_ESHUTDOWN 108++/* The value of ESOCKTNOSUPPORT. */+#define CONST_ESOCKTNOSUPPORT 94++/* The value of ESPIPE. */+#define CONST_ESPIPE 29++/* The value of ESRCH. */+#define CONST_ESRCH 3++/* The value of ESRMNT. */+#define CONST_ESRMNT 69++/* The value of ESTALE. */+#define CONST_ESTALE 116++/* The value of ETIME. */+#define CONST_ETIME 62++/* The value of ETIMEDOUT. */+#define CONST_ETIMEDOUT 110++/* The value of ETOOMANYREFS. */+#define CONST_ETOOMANYREFS 109++/* The value of ETXTBSY. */+#define CONST_ETXTBSY 26++/* The value of EUSERS. */+#define CONST_EUSERS 87++/* The value of EWOULDBLOCK. */+#define CONST_EWOULDBLOCK 11++/* The value of EXDEV. */+#define CONST_EXDEV 18++/* The value of O_BINARY. */+#define CONST_O_BINARY 0++/* The value of SIGINT. */+#define CONST_SIGINT 2++/* Define to 1 if you have the <ctype.h> header file. */+#define HAVE_CTYPE_H 1++/* Define to 1 if you have the <dirent.h> header file. */+#define HAVE_DIRENT_H 1++/* Define to 1 if you have the <errno.h> header file. */+#define HAVE_ERRNO_H 1++/* Define to 1 if you have the <fcntl.h> header file. */+#define HAVE_FCNTL_H 1++/* Define to 1 if you have the `ftruncate' function. */+#define HAVE_FTRUNCATE 1++/* Define to 1 if you have the `getclock' function. */+/* #undef HAVE_GETCLOCK */++/* Define to 1 if you have the `getrusage' function. */+#define HAVE_GETRUSAGE 1++/* Define to 1 if you have the <inttypes.h> header file. */+#define HAVE_INTTYPES_H 1++/* Define to 1 if you have the `iswspace' function. */+#define HAVE_ISWSPACE 1++/* Define to 1 if you have the <limits.h> header file. */+#define HAVE_LIMITS_H 1++/* Define to 1 if the system has the type `long long'. */+#define HAVE_LONG_LONG 1++/* Define to 1 if you have the `lstat' function. */+#define HAVE_LSTAT 1++/* Define to 1 if you have the <memory.h> header file. */+#define HAVE_MEMORY_H 1++/* Define to 1 if you have the `readdir_r' function. */+#define HAVE_READDIR_R 1++/* Define to 1 if you have the <signal.h> header file. */+#define HAVE_SIGNAL_H 1++/* Define to 1 if you have the <stdint.h> header file. */+#define HAVE_STDINT_H 1++/* Define to 1 if you have the <stdlib.h> header file. */+#define HAVE_STDLIB_H 1++/* Define to 1 if you have the <strings.h> header file. */+#define HAVE_STRINGS_H 1++/* Define to 1 if you have the <string.h> header file. */+#define HAVE_STRING_H 1++/* Define to 1 if you have the <sys/resource.h> header file. */+#define HAVE_SYS_RESOURCE_H 1++/* Define to 1 if you have the <sys/select.h> header file. */+#define HAVE_SYS_SELECT_H 1++/* Define to 1 if you have the <sys/stat.h> header file. */+#define HAVE_SYS_STAT_H 1++/* Define to 1 if you have the <sys/syscall.h> header file. */+#define HAVE_SYS_SYSCALL_H 1++/* Define to 1 if you have the <sys/timeb.h> header file. */+#define HAVE_SYS_TIMEB_H 1++/* 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. */+#define HAVE_SYS_TIMES_H 1++/* Define to 1 if you have the <sys/time.h> header file. */+#define HAVE_SYS_TIME_H 1++/* Define to 1 if you have the <sys/types.h> header file. */+#define HAVE_SYS_TYPES_H 1++/* Define to 1 if you have the <sys/utsname.h> header file. */+#define HAVE_SYS_UTSNAME_H 1++/* Define to 1 if you have the <sys/wait.h> header file. */+#define HAVE_SYS_WAIT_H 1++/* Define to 1 if you have the <termios.h> header file. */+#define HAVE_TERMIOS_H 1++/* Define to 1 if you have the `times' function. */+#define HAVE_TIMES 1++/* Define to 1 if you have the <time.h> header file. */+#define HAVE_TIME_H 1++/* Define to 1 if you have the <unistd.h> header file. */+#define HAVE_UNISTD_H 1++/* Define to 1 if you have the <utime.h> header file. */+#define HAVE_UTIME_H 1++/* Define to 1 if you have the <wctype.h> header file. */+#define HAVE_WCTYPE_H 1++/* 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 cc_t */+#define HTYPE_CC_T Word8++/* Define to Haskell type for char */+#define HTYPE_CHAR Int8++/* Define to Haskell type for clock_t */+#define HTYPE_CLOCK_T Int32++/* Define to Haskell type for dev_t */+#define HTYPE_DEV_T Word64++/* Define to Haskell type for double */+#define HTYPE_DOUBLE Double++/* Define to Haskell type for float */+#define HTYPE_FLOAT Float++/* Define to Haskell type for gid_t */+#define HTYPE_GID_T Word32++/* Define to Haskell type for ino_t */+#define HTYPE_INO_T Word64++/* Define to Haskell type for int */+#define HTYPE_INT Int32++/* Define to Haskell type for intmax_t */+#define HTYPE_INTMAX_T Int64++/* Define to Haskell type for intptr_t */+#define HTYPE_INTPTR_T Int32++/* Define to Haskell type for long */+#define HTYPE_LONG Int32++/* Define to Haskell type for long long */+#define HTYPE_LONG_LONG Int64++/* Define to Haskell type for mode_t */+#define HTYPE_MODE_T Word32++/* Define to Haskell type for nlink_t */+#define HTYPE_NLINK_T Word32++/* Define to Haskell type for off_t */+#define HTYPE_OFF_T Int64++/* Define to Haskell type for pid_t */+#define HTYPE_PID_T Int32++/* Define to Haskell type for ptrdiff_t */+#define HTYPE_PTRDIFF_T Int32++/* Define to Haskell type for rlim_t */+#define HTYPE_RLIM_T Word64++/* Define to Haskell type for short */+#define HTYPE_SHORT Int16++/* Define to Haskell type for signed char */+#define HTYPE_SIGNED_CHAR Int8++/* Define to Haskell type for sig_atomic_t */+#define HTYPE_SIG_ATOMIC_T Int32++/* Define to Haskell type for size_t */+#define HTYPE_SIZE_T Word32++/* Define to Haskell type for speed_t */+#define HTYPE_SPEED_T Word32++/* Define to Haskell type for ssize_t */+#define HTYPE_SSIZE_T Int32++/* Define to Haskell type for tcflag_t */+#define HTYPE_TCFLAG_T Word32++/* Define to Haskell type for time_t */+#define HTYPE_TIME_T Int32++/* Define to Haskell type for uid_t */+#define HTYPE_UID_T Word32++/* Define to Haskell type for uintmax_t */+#define HTYPE_UINTMAX_T Word64++/* Define to Haskell type for uintptr_t */+#define HTYPE_UINTPTR_T Word32++/* Define to Haskell type for unsigned char */+#define HTYPE_UNSIGNED_CHAR Word8++/* Define to Haskell type for unsigned int */+#define HTYPE_UNSIGNED_INT Word32++/* Define to Haskell type for unsigned long */+#define HTYPE_UNSIGNED_LONG Word32++/* Define to Haskell type for unsigned long long */+#define HTYPE_UNSIGNED_LONG_LONG Word64++/* Define to Haskell type for unsigned short */+#define HTYPE_UNSIGNED_SHORT Word16++/* Define to Haskell type for wchar_t */+#define HTYPE_WCHAR_T Int32++/* Define to Haskell type for wint_t */+/* #undef HTYPE_WINT_T */++/* Define to the address where bug reports for this package should be sent. */+#define PACKAGE_BUGREPORT "libraries@haskell.org"++/* Define to the full name of this package. */+#define PACKAGE_NAME "Haskell base package"++/* Define to the full name and version of this package. */+#define PACKAGE_STRING "Haskell base package 1.0"++/* Define to the one symbol short name of this package. */+#define PACKAGE_TARNAME "base"++/* Define to the version of this package. */+#define PACKAGE_VERSION "1.0"++/* readdir() sets errno to this upon EOF */+#define READDIR_ERRNO_EOF 0++/* Define to 1 if you have the ANSI C header files. */+#define STDC_HEADERS 1++/* Number of bits in a file offset, on hosts where this is settable. */+#define _FILE_OFFSET_BITS 64++/* Define for large files, on AIX-style hosts. */+/* #undef _LARGE_FILES */++/* Define to empty if `const' does not conform to ANSI C. */+/* #undef const */
+ include/Typeable.h view
@@ -0,0 +1,149 @@+{- --------------------------------------------------------------------------+// Macros to help make Typeable instances.+//+// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines+//+//	instance Typeable/n/ tc+//	instance Typeable a => Typeable/n-1/ (tc a)+//	instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b)+//	...+//	instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an)+// --------------------------------------------------------------------------+-}++#ifndef TYPEABLE_H+#define TYPEABLE_H++#define INSTANCE_TYPEABLE0(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }++#ifdef __GLASGOW_HASKELL__++--  // For GHC, the extra instances follow from general instance declarations+--  // defined in Data.Typeable.++#define INSTANCE_TYPEABLE1(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE2(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE3(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE4(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE5(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE6(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] }++#define INSTANCE_TYPEABLE7(tycon,tcname,str) \+tcname :: TyCon; \+tcname = mkTyCon str; \+instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] }++#else /* !__GLASGOW_HASKELL__ */++#define INSTANCE_TYPEABLE1(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE2(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable1 (tycon a) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE3(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable2 (tycon a) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE4(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable3 (tycon a) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b) => Typeable2 (tycon a b) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable1 (tycon a b c) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (tycon a b c d) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE5(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable4 (tycon a) where { \+  typeOf4 = typeOf4Default }; \+instance (Typeable a, Typeable b) => Typeable3 (tycon a b) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable2 (tycon a b c) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable1 (tycon a b c d) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable (tycon a b c d e) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE6(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable5 (tycon a) where { \+  typeOf5 = typeOf5Default }; \+instance (Typeable a, Typeable b) => Typeable4 (tycon a b) where { \+  typeOf4 = typeOf4Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable3 (tycon a b c) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable2 (tycon a b c d) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable1 (tycon a b c d e) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Typeable (tycon a b c d e f) where { \+  typeOf = typeOfDefault }++#define INSTANCE_TYPEABLE7(tycon,tcname,str) \+tcname = mkTyCon str; \+instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] }; \+instance Typeable a => Typeable6 (tycon a) where { \+  typeOf6 = typeOf6Default }; \+instance (Typeable a, Typeable b) => Typeable5 (tycon a b) where { \+  typeOf5 = typeOf5Default }; \+instance (Typeable a, Typeable b, Typeable c) => Typeable4 (tycon a b c) where { \+  typeOf4 = typeOf4Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable3 (tycon a b c d) where { \+  typeOf3 = typeOf3Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => Typeable2 (tycon a b c d e) where { \+  typeOf2 = typeOf2Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => Typeable1 (tycon a b c d e f) where { \+  typeOf1 = typeOf1Default }; \+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g) => Typeable (tycon a b c d e f g) where { \+  typeOf = typeOfDefault }++#endif /* !__GLASGOW_HASKELL__ */++#endif
+ include/WCsubst.h view
@@ -0,0 +1,24 @@+#ifndef WCSUBST_INCL++#define WCSUBST_INCL++#include <stdlib.h>++int u_iswupper(int wc);+int u_iswdigit(int wc);+int u_iswalpha(int wc);+int u_iswcntrl(int wc);+int u_iswspace(int wc);+int u_iswprint(int wc);+int u_iswlower(int wc);++int u_iswalnum(int wc);++int u_towlower(int wc);+int u_towupper(int wc);+int u_towtitle(int wc);++int u_gencat(int wc);++#endif+
+ include/consUtils.h view
@@ -0,0 +1,12 @@+/* + * (c) The University of Glasgow, 2000-2002+ *+ * Win32 Console API helpers.+ */+#ifndef __CONSUTILS_H__+#define __CONSUTILS_H__+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);+extern int flush_input_console__ (int fd);+#endif
+ include/dirUtils.h view
@@ -0,0 +1,11 @@+/* + * (c) The University of Glasgow 2002+ *+ * Directory Runtime Support+ */+#ifndef __DIRUTILS_H__+#define __DIRUTILS_H__++extern int __hscore_readdir(DIR *dirPtr, struct dirent **pDirEnt);++#endif /* __DIRUTILS_H__ */
+ install-sh view
@@ -0,0 +1,519 @@+#!/bin/sh+# install - install a program, script, or datafile++scriptversion=2006-12-25.00++# 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+	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+  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+  trap '(exit $?); exit' 1 2 13 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 starting with `-'.+  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+    # Protect names starting with `-'.+    case $dst in+      -*) dst=./$dst;;+    esac++    # 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-writeable 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 -z "$d" && 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-end: "$"+# End: